annotate functions-all-clayton-12-13.r @ 20:6f6a9fbe264e draft default tip

Uploaded
author modencode-dcc
date Mon, 21 Jan 2013 13:36:24 -0500
parents 5e6efd5f3567
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
3
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1 # revised on 2-20-10
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2 # - fix error in pass.structure: reverse rank.combined, so that big sig.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3 # are ranked with small numbers (1, 2, ...)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
4 # - fix error on get.ez.tt.all: get ez.cutoff from sorted e.z
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
5
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
6 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
7 # modified EM procedure to compute empirical CDF more precisely - 09/2009
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
8
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
9
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
10
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
11 # this file contains the functions for
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
12 # 1. computing the correspondence profile (upper rank intersection and derivatives)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
13 # 2. inference of copula mixture model
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
14 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
15 # It also has functions for
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
16 # 1. reading peak caller results
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
17 # 2. processing and matching called peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
18 # 3. plotting results
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
19
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
20
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
21 ################ read peak caller results
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
22
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
23 # process narrow peak format
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
24 # some peak callers may not report q-values, p-values or fold of enrichment
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
25 # need further process before comparison
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
26 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
27 # stop.exclusive: Is the basepair of peak.list$stop exclusive? In narrowpeak and broadpeak format they are exclusive.
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
28 # If it is exclusive, we need subtract peak.list$stop by 1 to avoid the same basepair being both a start and a stop of two
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
29 # adjacent peaks, which creates trouble for finding correct intersect
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
30 process.narrowpeak <- function(narrow.file, chr.size, half.width=NULL, summit="offset", stop.exclusive=T, broadpeak=F){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
31
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
32
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
33 aa <- read.table(narrow.file)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
34
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
35 if(broadpeak){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
36 bb.ori <- data.frame(chr=aa$V1, start=aa$V2, stop=aa$V3, signal.value=aa$V7, p.value=aa$V8, q.value=aa$V9)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
37 }else{
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
38 bb.ori <- data.frame(chr=aa$V1, start=aa$V2, stop=aa$V3, signal.value=aa$V7, p.value=aa$V8, q.value=aa$V9, summit=aa$V10)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
39 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
40
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
41 if(summit=="summit"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
42 bb.ori$summit <- bb.ori$summit-bb.ori$start # change summit to offset to avoid error when concatenating chromosomes
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
43 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
44
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
45 bb <- concatenate.chr(bb.ori, chr.size)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
46
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
47 #bb <- bb.ori
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
48
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
49 # remove the peaks that has the same start and stop value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
50 bb <- bb[bb$start != bb$stop,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
51
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
52 if(stop.exclusive==T){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
53 bb$stop <- bb$stop-1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
54 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
55
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
56 if(!is.null(half.width)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
57 bb$start.ori <- bb$start
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
58 bb$stop.ori <- bb$stop
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
59
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
60 # if peak is narrower than the specified window, stay with its width
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
61 # otherwise chop wider peaks to specified width
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
62 width <- bb$stop-bb$start +1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
63 is.wider <- width > 2*half.width
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
64
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
65 if(summit=="offset" | summit=="summit"){ # if summit is offset from start
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
66 bb$start[is.wider] <- bb$start.ori[is.wider] + bb$summit[is.wider]-half.width
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
67 bb$stop[is.wider] <- bb$start.ori[is.wider] + bb$summit[is.wider]+half.width
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
68 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
69 if(summit=="unknown"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
70 bb$start[is.wider] <- bb$start.ori[is.wider]+round(width[is.wider]/2) - half.width
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
71 bb$stop[is.wider] <- bb$start.ori[is.wider]+round(width[is.wider]/2) + half.width
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
72 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
73 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
74 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
75
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
76 bb <- clean.data(bb)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
77 invisible(list(data.ori=bb.ori, data.cleaned=bb))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
78 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
79
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
80 # clean data
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
81 # and concatenate chromosomes if needed
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
82 clean.data <- function(adata){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
83
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
84 # remove the peaks that has the same start and stop value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
85 adata <- adata[adata$start != adata$stop,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
86
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
87 # if some stops and starts are the same, need fix them
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
88 stop.in.start <- is.element(adata$stop, adata$start)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
89 n.fix <- sum(stop.in.start)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
90 if(n.fix >0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
91 print(paste("Fix", n.fix, "stops\n"))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
92 adata$stop[stop.in.start] <- adata$stop[stop.in.start]-1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
93 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
94
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
95 return(adata)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
96 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
97
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
98 # concatenate peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
99 # peaks: the dataframe to have all the peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
100 # chr.file: the file to keep the length of each chromosome
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
101 # chr files should come from the species that the data is from
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
102 #concatenate.chr <- function(peaks, chr.size){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
103
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
104 # chr.size <- read.table(chr.file)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
105 # chr.o <- order(chr.size[,1])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
106 # chr.size <- chr.size[chr.o,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
107 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
108 # chr.shift <- cumsum(c(0, chr.size[-nrow(chr.size),2]))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
109 # chr.size.cum <- data.frame(chr=chr.size[,1], shift=chr.shift)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
110 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
111 # for(i in 1:nrow(chr.size)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
112 # is.in <- as.character(peaks$chr) == as.character(chr.size.cum$chr[i])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
113 # if(sum(is.in)>0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
114 # peaks[is.in,]$start <- peaks[is.in,]$start + chr.size.cum$shift[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
115 # peaks[is.in,]$stop <- peaks[is.in,]$stop + chr.size.cum$shift[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
116 # }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
117 # }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
118 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
119 # invisible(peaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
120 #}
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
121
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
122
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
123
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
124
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
125 # concatenate peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
126 # peaks: the dataframe to have all the peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
127 # chr.file: the file to keep the length of each chromosome
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
128 # chr files should come from the species that the data is from
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
129 concatenate.chr <- function(peaks, chr.size){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
130
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
131 # chr.size <- read.table(chr.file)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
132 chr.o <- order(chr.size[,1])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
133 chr.size <- chr.size[chr.o,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
134
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
135 chr.shift <- cumsum(c(0, chr.size[-nrow(chr.size),2]))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
136 chr.size.cum <- data.frame(chr=chr.size[,1], shift=chr.shift)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
137
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
138 peaks$start.ori <- peaks$start
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
139 peaks$stop.ori <- peaks$stop
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
140
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
141 for(i in 1:nrow(chr.size)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
142 is.in <- as.character(peaks$chr) == as.character(chr.size.cum$chr[i])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
143 if(sum(is.in)>0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
144 peaks[is.in,]$start <- peaks[is.in,]$start + chr.size.cum$shift[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
145 peaks[is.in,]$stop <- peaks[is.in,]$stop + chr.size.cum$shift[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
146 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
147 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
148
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
149 invisible(peaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
150 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
151
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
152
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
153 deconcatenate.chr <- function(peaks, chr.size){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
154
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
155 chr.o <- order(chr.size[,1])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
156 chr.size <- chr.size[chr.o,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
157
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
158 chr.shift <- cumsum(c(0, chr.size[-nrow(chr.size),2]))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
159 chr.size.cum <- data.frame(chr=chr.size[,1], shift=chr.shift)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
160
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
161 peaks$chr <- rep(NA, nrow(peaks))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
162
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
163 for(i in 1:(nrow(chr.size.cum)-1)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
164 is.in <- peaks$start > chr.size.cum[i,2] & peaks$start <= chr.size.cum[i+1, 2]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
165 if(sum(is.in)>0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
166 peaks[is.in,]$start <- peaks[is.in,]$start - chr.size.cum[i,2]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
167 peaks[is.in,]$stop <- peaks[is.in,]$stop - chr.size.cum[i,2]+1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
168 peaks[is.in,]$chr <- chr.size[i,1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
169 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
170 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
171
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
172 if(i == nrow(chr.size.cum)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
173 is.in <- peaks$start > chr.size.cum[i, 2]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
174 if(sum(is.in)>0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
175 peaks[is.in,]$start <- peaks[is.in,]$start - chr.size.cum[i,2]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
176 peaks[is.in,]$stop <- peaks[is.in,]$stop - chr.size.cum[i,2]+1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
177 peaks[is.in,]$chr <- chr.size[i,1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
178 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
179 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
180
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
181 invisible(peaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
182 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
183
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
184 ################ preprocessing peak calling output
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
185
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
186
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
187 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
188 # read two calling results and sort by peak starting locations,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
189 # then find overlap between peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
190 # INPUT:
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
191 # rep1: the 1st replicate
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
192 # rep2: the 2nd replicate
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
193 # OUTPUT:
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
194 # id1, id2: the labels for the identified peaks on the replicates
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
195 find.overlap <- function(rep1, rep2){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
196
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
197 o1 <- order(rep1$start)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
198 rep1 <- rep1[o1,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
199
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
200 o2 <- order(rep2$start)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
201 rep2 <- rep2[o2,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
202
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
203 n1 <- length(o1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
204 n2 <- length(o2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
205
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
206 # assign common ID to peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
207 id1 <- rep(0, n1) # ID assigned on rep1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
208 id2 <- rep(0, n2) # ID assigned on rep2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
209 id <- 1 # keep track common id's
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
210
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
211 # check if two replicates overlap with each other
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
212 i <- 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
213 j <- 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
214
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
215 while(i <= n1|| j <= n2){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
216
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
217 # && (id1[n1] ==0 || id2[n2] ==0)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
218
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
219 # if one list runs out
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
220 if(i > n1 && j < n2){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
221
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
222 j <- j+1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
223 id2[j] <- id
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
224 id <- id +1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
225 next
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
226 } else{
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
227 if(j > n2 && i < n1){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
228 i <- i+1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
229 id1[i] <- id
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
230 id <- id +1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
231 next
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
232 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
233 if(i >= n1 && j >=n2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
234 break
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
235 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
236 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
237
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
238 # if not overlap
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
239
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
240 if(!(rep1$start[i] <= rep2$stop[j] && rep2$start[j] <= rep1$stop[i])){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
241
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
242 # at the start of loop, when both are not assigned an ID
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
243 # the one locates in front is assigned first
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
244 if(id1[i] ==0 && id2[j]==0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
245 if(rep1$stop[i] < rep2$stop[j]){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
246 id1[i] <- id
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
247 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
248 id2[j] <- id
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
249 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
250 } else { # in the middle of the loop, when one is already assigned
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
251 # The one that has not assigned gets assigned
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
252 # if(id1[i] ==0){ # id1[i] is not assigned
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
253 # id1[i] <- id
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
254 # } else { # id2[i] is not assigned
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
255 # id2[j] <- id
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
256 # }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
257
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
258 # order the id according to location
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
259 if(rep1$stop[i] <= rep2$stop[j]){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
260 id1[i] <- max(id2[j], id1[i])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
261 id2[j] <- id
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
262 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
263 if(rep1$stop[i] > rep2$stop[j]){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
264 id2[j] <- max(id1[i], id2[j])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
265 id1[i] <- id
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
266 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
267 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
268
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
269 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
270
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
271 id <- id +1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
272
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
273 } else { # if overlap
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
274
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
275 if(id1[i] == 0 && id2[j] == 0){ # not assign label yet
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
276 id1[i] <- id
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
277 id2[j] <- id
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
278 id <- id +1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
279 } else { # one peak is already assigned label, the other is 0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
280
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
281 id1[i] <- max(id1[i], id2[j]) # this is a way to copy the label of the assigned peak without knowing which one is already assigned
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
282 id2[j] <- id1[i] # syncronize the labels
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
283 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
284
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
285 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
286
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
287 if(rep1$stop[i] < rep2$stop[j]){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
288 i <- i+1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
289 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
290 j <- j+1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
291 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
292
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
293 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
294
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
295 invisible(list(id1=id1, id2=id2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
296
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
297 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
298
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
299 # Impute the missing significant value for the peaks called only on one replicate.
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
300 # value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
301 # INPUT:
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
302 # rep1, rep2: the two peak calling output
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
303 # id1, id2: the IDs assigned by function find.overlap, vectors
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
304 # If id1[i]==id2[j], peak i on rep1 overlaps with peak j on rep2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
305 # p.value.impute: the significant value to impute for the missing peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
306 # OUTPUT:
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
307 # rep1, rep2: peaks ordered by the start locations with imputed peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
308 # id1, id2: the IDs with imputed peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
309 fill.missing.peaks <- function(rep1, rep2, id1, id2, p.value.impute){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
310
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
311 # rep1 <- data.frame(chr=rep1$chr, start=rep1$start, stop=rep1$stop, sig.value=rep1$sig.value)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
312 # rep2 <- data.frame(chr=rep2$chr, start=rep2$start, stop=rep2$stop, sig.value=rep2$sig.value)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
313
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
314 o1 <- order(rep1$start)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
315 rep1 <- rep1[o1,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
316
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
317 o2 <- order(rep2$start)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
318 rep2 <- rep2[o2,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
319
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
320 entry.in1.not2 <- !is.element(id1, id2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
321 entry.in2.not1 <- !is.element(id2, id1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
322
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
323 if(sum(entry.in1.not2) > 0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
324
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
325 temp1 <- rep1[entry.in1.not2, ]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
326
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
327 # impute sig.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
328 temp1$sig.value <- p.value.impute
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
329 temp1$signal.value <- p.value.impute
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
330 temp1$p.value <- p.value.impute
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
331 temp1$q.value <- p.value.impute
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
332
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
333 rep2.filled <- rbind(rep2, temp1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
334 id2.filled <- c(id2, id1[entry.in1.not2])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
335 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
336 id2.filled <- id2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
337 rep2.filled <- rep2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
338 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
339
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
340 if(sum(entry.in2.not1) > 0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
341
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
342 temp2 <- rep2[entry.in2.not1, ]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
343
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
344 # fill in p.values to 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
345 temp2$sig.value <- p.value.impute
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
346 temp2$signal.value <- p.value.impute
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
347 temp2$p.value <- p.value.impute
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
348 temp2$q.value <- p.value.impute
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
349
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
350
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
351 # append to the end
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
352 rep1.filled <- rbind(rep1, temp2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
353
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
354 id1.filled <- c(id1, id2[entry.in2.not1])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
355 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
356 id1.filled <- id1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
357 rep1.filled <- rep1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
358 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
359
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
360 # sort rep1 and rep2 by the same id
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
361 o1 <- order(id1.filled)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
362 rep1.ordered <- rep1.filled[o1, ]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
363
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
364 o2 <- order(id2.filled)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
365 rep2.ordered <- rep2.filled[o2, ]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
366
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
367 invisible(list(rep1=rep1.ordered, rep2=rep2.ordered,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
368 id1=id1.filled[o1], id2=id2.filled[o2]))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
369 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
370
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
371 # Merge peaks with same ID on the same replicates
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
372 # (They are generated if two peaks on rep1 map to the same peak on rep2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
373 # need peak.list have 3 columns: start, stop and sig.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
374 merge.peaks <- function(peak.list, id){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
375
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
376 i <- 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
377 j <- 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
378 dup.index <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
379 sig.value <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
380 start.new <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
381 stop.new <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
382 id.new <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
383
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
384 # original data
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
385 chr <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
386 start.ori <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
387 stop.ori <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
388
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
389 signal.value <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
390 p.value <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
391 q.value <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
392
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
393 while(i < length(id)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
394
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
395 if(id[i] == id[i+1]){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
396 dup.index <- c(dup.index, i, i+1) # push on dup.index
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
397 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
398 if(length(dup.index)>0){ # pop from dup.index
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
399 sig.value[j] <- mean(peak.list$sig.value[unique(dup.index)]) # mean of -log(pvalue)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
400 start.new[j] <- peak.list$start[min(dup.index)]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
401 stop.new[j] <- peak.list$stop[max(dup.index)]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
402 id.new[j] <- id[max(dup.index)]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
403
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
404 signal.value[j] <- mean(peak.list$signal.value[unique(dup.index)]) # mean of -log(pvalue)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
405 p.value[j] <- mean(peak.list$p.value[unique(dup.index)]) # mean of -log(pvalue)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
406 q.value[j] <- mean(peak.list$q.value[unique(dup.index)]) # mean of -log(pvalue)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
407
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
408 chr[j] <- as.character(peak.list$chr[min(dup.index)])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
409 start.ori[j] <- peak.list$start.ori[min(dup.index)]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
410 stop.ori[j] <- peak.list$stop.ori[max(dup.index)]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
411
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
412 dup.index <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
413 } else { # nothing to pop
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
414 sig.value[j] <- peak.list$sig.value[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
415 start.new[j] <- peak.list$start[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
416 stop.new[j] <- peak.list$stop[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
417 id.new[j] <- id[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
418
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
419 signal.value[j] <- peak.list$signal.value[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
420 p.value[j] <- peak.list$p.value[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
421 q.value[j] <- peak.list$q.value[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
422
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
423 chr[j] <- as.character(peak.list$chr[i])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
424 start.ori[j] <- peak.list$start.ori[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
425 stop.ori[j] <- peak.list$stop.ori[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
426
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
427 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
428 j <- j+1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
429 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
430 i <- i+1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
431 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
432
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
433 data.new <- data.frame(id=id.new, sig.value=sig.value, start=start.new, stop=stop.new, signal.value=signal.value, p.value=p.value, q.value=q.value, chr=chr, start.ori=start.ori, stop.ori=stop.ori)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
434 invisible(data.new)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
435 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
436
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
437
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
438
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
439
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
440
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
441 # a wrap function to fill in missing peaks, merge peaks and impute significant values
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
442 # out1 and out2 are two peak calling outputs
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
443 pair.peaks <- function(out1, out2, p.value.impute=0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
444
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
445 aa <- find.overlap(out1, out2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
446 bb <- fill.missing.peaks(out1, out2, aa$id1, aa$id2, p.value.impute=0)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
447
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
448 cc1 <- merge.peaks(bb$rep1, bb$id1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
449 cc2 <- merge.peaks(bb$rep2, bb$id2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
450
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
451 invisible(list(merge1=cc1, merge2=cc2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
452 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
453
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
454
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
455
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
456 # overlap.ratio is a parameter to define the percentage of overlap
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
457 # if overlap.ratio =0, 1 basepair overlap is counted as overlap
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
458 # if overlap.ratio between 0 and 1, it is the minimum proportion of
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
459 # overlap required to be called as a match
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
460 # it is computed as the overlap part/min(peak1.length, peak2.length)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
461 pair.peaks.filter <- function(out1, out2, p.value.impute=0, overlap.ratio=0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
462
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
463 aa <- find.overlap(out1, out2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
464 bb <- fill.missing.peaks(out1, out2, aa$id1, aa$id2, p.value.impute=0)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
465
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
466 cc1 <- merge.peaks(bb$rep1, bb$id1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
467 cc2 <- merge.peaks(bb$rep2, bb$id2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
468
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
469 frag12 <- cbind(cc1$start, cc1$stop, cc2$start, cc2$stop)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
470
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
471 frag.ratio <- apply(frag12, 1, overlap.middle)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
472
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
473 frag.ratio[cc1$sig.value==p.value.impute | cc2$sig.value==p.value.impute] <- 0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
474
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
475 cc1$frag.ratio <- frag.ratio
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
476 cc2$frag.ratio <- frag.ratio
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
477
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
478 merge1 <- cc1[cc1$frag.ratio >= overlap.ratio,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
479 merge2 <- cc2[cc2$frag.ratio >= overlap.ratio,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
480
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
481 invisible(list(merge1=merge1, merge2=merge2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
482 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
483
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
484 # x[1], x[2] are the start and end of the first fragment
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
485 # and x[3] and x[4] are the start and end of the 2nd fragment
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
486 # If there are two fragments, we can find the overlap by ordering the
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
487 # start and stop of all the ends and find the difference between the middle two
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
488 overlap.middle <- function(x){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
489
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
490 x.o <- x[order(x)]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
491 f1 <- x[2]-x[1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
492 f2 <- x[4]-x[3]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
493
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
494 f.overlap <- abs(x.o[3]-x.o[2])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
495 f.overlap.ratio <- f.overlap/min(f1, f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
496
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
497 return(f.overlap.ratio)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
498 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
499
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
500
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
501
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
502 #######
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
503 ####### compute correspondence profile
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
504 #######
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
505
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
506 # compute upper rank intersection for one t
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
507 # tv: the upper percentile
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
508 # x is sorted by the order of paired variable
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
509 comp.uri <- function(tv, x){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
510 n <- length(x)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
511 qt <- quantile(x, prob=1-tv[1]) # tv[1] is t
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
512 # sum(x[1:ceiling(n*tv[2])] >= qt)/n/tv[2]- tv[1]*tv[2] #tv[2] is v
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
513 sum(x[1:ceiling(n*tv[2])] >= qt)/n
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
514
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
515 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
516
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
517 # compute the correspondence profile
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
518 # tt, vv: vector between (0, 1) for percentages
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
519 get.uri.2d <- function(x1, x2, tt, vv, spline.df=NULL){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
520
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
521 o <- order(x1, x2, decreasing=T)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
522
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
523 # sort x2 by the order of x1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
524 x2.ordered <- x2[o]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
525
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
526 tv <- cbind(tt, vv)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
527 ntotal <- length(x1) # number of peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
528
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
529 uri <- apply(tv, 1, comp.uri, x=x2.ordered)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
530
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
531 # compute the derivative of URI vs t using small bins
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
532 uri.binned <- uri[seq(1, length(uri), by=4)]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
533 tt.binned <- tt[seq(1, length(uri), by=4)]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
534 uri.slope <- (uri.binned[2:(length(uri.binned))] - uri.binned[1:(length(uri.binned)-1)])/(tt.binned[2:(length(uri.binned))] - tt.binned[1:(length(tt.binned)-1)])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
535
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
536 # smooth uri using spline
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
537 # first find where the jump is and don't fit the jump
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
538 # this is the index on the left
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
539 # jump.left.old <- which.max(uri[-1]-uri[-length(uri)])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
540 short.list.length <- min(sum(x1>0)/length(x1), sum(x2>0)/length(x2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
541
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
542 if(short.list.length < max(tt)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
543 jump.left <- which(tt>short.list.length)[1]-1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
544 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
545 jump.left <- which.max(tt)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
546 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
547
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
548 # reversed.index <- seq(length(tt), 1, by=-1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
549 # nequal <- sum(uri[reversed.index]== tt[reversed.index])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
550 # temp <- which(uri[reversed.index]== tt[reversed.index])[nequal]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
551 # jump.left <- length(tt)-temp
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
552
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
553 if(jump.left < 6){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
554 jump.left <- length(tt)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
555 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
556
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
557
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
558 if(is.null(spline.df))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
559 uri.spl <- smooth.spline(tt[1:jump.left], uri[1:jump.left], df=6.4)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
560 else{
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
561 uri.spl <- smooth.spline(tt[1:jump.left], uri[1:jump.left], df=spline.df)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
562 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
563 # predict the first derivative
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
564 uri.der <- predict(uri.spl, tt[1:jump.left], deriv=1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
565
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
566 invisible(list(tv=tv, uri=uri,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
567 uri.slope=uri.slope, t.binned=tt.binned[2:length(uri.binned)],
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
568 uri.spl=uri.spl, uri.der=uri.der, jump.left=jump.left,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
569 ntotal=ntotal))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
570 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
571
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
572
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
573 # change the scale of uri from based on t (percentage) to n (number of peaks or basepairs)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
574 # this is for plotting multiple pairwise URI's on the same plot
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
575 scale.t2n <- function(uri){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
576
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
577 ntotal <- uri$ntotal
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
578 tv <- uri$tv*uri$ntotal
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
579 uri.uri <- uri$uri*uri$ntotal
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
580 jump.left <- uri$jump.left
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
581 uri.spl <- uri$uri.spl
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
582 uri.spl$x <- uri$uri.spl$x*uri$ntotal
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
583 uri.spl$y <- uri$uri.spl$y*uri$ntotal
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
584
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
585 t.binned <- uri$t.binned*uri$ntotal
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
586 uri.slope <- uri$uri.slope
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
587 uri.der <- uri$uri.der
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
588 uri.der$x <- uri$uri.der$x*uri$ntotal
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
589 uri.der$y <- uri$uri.der$y
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
590
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
591 uri.n <- list(tv=tv, uri=uri.uri, t.binned=t.binned, uri.slope=uri.slope, uri.spl=uri.spl, uri.der=uri.der, ntotal=ntotal, jump.left=jump.left)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
592 return(uri.n)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
593 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
594
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
595
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
596
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
597
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
598 # a wrapper for running URI for peaks from peak calling results
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
599 # both data1 and data2 are calling results in narrowpeak format
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
600 compute.pair.uri <- function(data.1, data.2, sig.value1="signal.value", sig.value2="signal.value", spline.df=NULL, overlap.ratio=0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
601
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
602 tt <- seq(0.01, 1, by=0.01)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
603 vv <- tt
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
604
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
605 if(sig.value1=="signal.value"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
606 data.1.enrich <- data.frame(chr=data.1$chr, start.ori=data.1$start.ori, stop.ori=data.1$stop.ori, start=data.1$start, stop=data.1$stop, sig.value=data.1$signal.value, signal.value=data.1$signal.value, p.value=data.1$p.value, q.value=data.1$q.value)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
607 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
608 if(sig.value1=="p.value"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
609 data.1.enrich <- data.frame(chr=data.1$chr, start.ori=data.1$start.ori, stop.ori=data.1$stop.ori, start=data.1$start, stop=data.1$stop, sig.value=data.1$p.value, signal.value=data.1$signal.value, p.value=data.1$p.value, q.value=data.1$q.value)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
610 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
611 if(sig.value1=="q.value"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
612 data.1.enrich <- data.frame(chr=data.1$chr, start.ori=data.1$start.ori, stop.ori=data.1$stop.ori, start=data.1$start, stop=data.1$stop, sig.value=data.1$q.value, signal.value=data.1$signal.value, p.value=data.1$p.value, q.value=data.1$q.value)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
613 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
614 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
615 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
616
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
617 if(sig.value2=="signal.value"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
618 data.2.enrich <- data.frame(chr=data.2$chr, start.ori=data.2$start.ori, stop.ori=data.2$stop.ori, start=data.2$start, stop=data.2$stop, sig.value=data.2$signal.value, signal.value=data.2$signal.value, p.value=data.2$p.value, q.value=data.2$q.value)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
619 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
620 if(sig.value2=="p.value"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
621 data.2.enrich <- data.frame(chr=data.2$chr, start.ori=data.2$start.ori, stop.ori=data.2$stop.ori, start=data.2$start, stop=data.2$stop, sig.value=data.2$p.value, signal.value=data.2$signal.value, p.value=data.2$p.value, q.value=data.2$q.value)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
622 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
623 if(sig.value2=="q.value"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
624 data.2.enrich <- data.frame(chr=data.2$chr, start.ori=data.2$start.ori, stop.ori=data.2$stop.ori, start=data.2$start, stop=data.2$stop, sig.value=data.2$q.value, signal.value=data.2$signal.value, p.value=data.2$p.value, q.value=data.2$q.value)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
625 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
626 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
627 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
628
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
629 ### by peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
630 # data12.enrich <- pair.peaks(data.1.enrich, data.2.enrich)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
631 data12.enrich <- pair.peaks.filter(data.1.enrich, data.2.enrich, p.value.impute=0, overlap.ratio)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
632 uri <- get.uri.2d(as.numeric(as.character(data12.enrich$merge1$sig.value)), as.numeric(as.character(data12.enrich$merge2$sig.value)), tt, vv, spline.df=spline.df)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
633 uri.n <- scale.t2n(uri)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
634
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
635 return(list(uri=uri, uri.n=uri.n, data12.enrich=data12.enrich, sig.value1=sig.value1, sig.value2=sig.value2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
636
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
637
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
638 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
639
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
640
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
641
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
642 # compute uri for matched sample
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
643 get.uri.matched <- function(data12, df=10){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
644
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
645 tt <- seq(0.01, 1, by=0.01)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
646 vv <- tt
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
647 uri <- get.uri.2d(data12$sample1$sig.value, data12$sample2$sig.value, tt, vv, spline.df=df)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
648
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
649 # change scale from t to n
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
650 uri.n <- scale.t2n(uri)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
651
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
652 return(list(uri=uri, uri.n=uri.n))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
653
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
654 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
655
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
656 # map.uv is a pair of significant values corresponding to specified consistency FDR
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
657 # assuming values in map.uv and qvalue are linearly related
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
658 # data.set is the original data set
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
659 # sig.value is the name of the significant value in map.uv, say enrichment
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
660 # nominal.value is the one we want to map to, say q-value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
661 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
662 map.sig.value <- function(data.set, map.uv, nominal.value){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
663
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
664 index.nominal <- which(names(data.set$merge1)==nominal.value)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
665 nentry <- nrow(map.uv)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
666 map.nominal <- rbind(map.uv[, c("sig.value1", "sig.value2")])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
667
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
668 for(i in 1:nentry){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
669
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
670 map.nominal[i, "sig.value1"] <- data.set$merge1[unique(which.min(abs(data.set$merge1$sig.value-map.uv[i, "sig.value1"]))), index.nominal]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
671 map.nominal[i, "sig.value2"] <- data.set$merge2[unique(which.min(abs(data.set$merge2$sig.value-map.uv[i, "sig.value2"]))), index.nominal]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
672 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
673
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
674 invisible(map.nominal)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
675 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
676
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
677
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
678 ############### plot correspondence profile
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
679
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
680 # plot multiple comparison wrt one template
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
681 # uri.list contains the total number of peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
682 # plot.missing=F: not plot the missing points on the right
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
683 plot.uri.group <- function(uri.n.list, plot.dir, file.name=NULL, legend.txt, xlab.txt="num of significant peaks", ylab.txt="num of peaks in common", col.start=0, col.txt=NULL, plot.missing=F, title.txt=NULL){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
684
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
685 if(is.null(col.txt))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
686 col.txt <- c("black", "red", "purple", "green", "blue", "cyan", "magenta", "orange", "grey")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
687
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
688 n <- length(uri.n.list)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
689
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
690 ntotal <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
691 for(i in 1:n)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
692 ntotal[i] <- uri.n.list[[i]]$ntotal
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
693
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
694 jump.left <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
695 jump.left.der <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
696 ncommon <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
697 for(i in 1:n){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
698 # jump.left[i] <- which.max(uri.n.list[[i]]$uri[-1]-uri.n.list[[i]]$uri[-length(uri.n.list[[i]]$uri)])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
699 # if(jump.left[i] < 6)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
700 # jump.left[i] <- length(uri.n.list[[i]]$uri)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
701
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
702 ## reversed.index <- seq(length(uri.n.list[[i]]$tv[,1]), 1, by=-1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
703 ## nequal <- sum(uri.n.list[[i]]$uri[reversed.index]== uri.n.list[[i]]$tv[reversed.index,1])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
704 ## temp <- which(uri.n.list[[i]]$uri[reversed.index]== uri.n.list[[i]]$tv[reversed.index,1])[nequal]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
705 ## jump.left[i] <- length(uri.n.list[[i]]$tv[,1])-temp
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
706 ##print(uri.n.list[[i]]$uri)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
707 ##print(uri.n.list[[i]]$tv[,1])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
708 ## jump.left[i] <- uri.n.list[[i]]$jump.left
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
709
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
710 # jump.left.der[i] <- sum(uri.n.list[[i]]$t.binned < uri.n.list[[i]]$uri.der$x[length(uri.n.list[[i]]$uri.der$x)])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
711
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
712 jump.left[i] <- uri.n.list[[i]]$jump.left
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
713 jump.left.der[i] <- jump.left[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
714 ncommon[i] <- uri.n.list[[i]]$tv[jump.left[i],1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
715 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
716
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
717
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
718 if(plot.missing){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
719 max.peak <- max(ntotal)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
720 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
721 max.peak <- max(ncommon)*1.05
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
722 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
723
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
724 if(!is.null(file.name)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
725 postscript(paste(plot.dir, "uri.", file.name, sep=""))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
726 par(mfrow=c(1,1), mar=c(5,5,4,2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
727 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
728
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
729 plot(uri.n.list[[1]]$tv[,1], uri.n.list[[1]]$uri, type="n", xlab=xlab.txt, ylab=ylab.txt, xlim=c(0, max.peak), ylim=c(0, max.peak), cex.lab=2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
730
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
731 for(i in 1:n){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
732
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
733 if(plot.missing){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
734 points(uri.n.list[[i]]$tv[,1], uri.n.list[[i]]$uri, col=col.txt[i+col.start], cex=0.5 )
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
735 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
736 points(uri.n.list[[i]]$tv[1:jump.left[i],1], uri.n.list[[i]]$uri[1:jump.left[i]], col=col.txt[i+col.start], cex=0.5)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
737 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
738 lines(uri.n.list[[i]]$uri.spl, col=col.txt[i+col.start], lwd=4)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
739 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
740 abline(coef=c(0,1), lty=3)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
741 legend(0, max.peak, legend=legend.txt, col=col.txt[(col.start+1):length(col.txt)], lty=1, lwd=3, cex=2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
742 if(!is.null(title))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
743 title(title.txt)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
744
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
745 if(!is.null(file.name)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
746 dev.off()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
747 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
748
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
749 if(!is.null(file.name)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
750 postscript(paste(plot.dir, "duri.", file.name, sep=""))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
751 par(mfrow=c(1,1), mar=c(5,5,4,2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
752 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
753 plot(uri.n.list[[1]]$t.binned, uri.n.list[[1]]$uri.slope, type="n", xlab=xlab.txt, ylab="slope", xlim=c(0, max.peak), ylim=c(0, 1.5), cex.lab=2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
754
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
755 for(i in 1:n){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
756 # if(plot.missing){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
757 # points(uri.n.list[[i]]$t.binned, uri.n.list[[i]]$uri.slope, col=col.txt[i+col.start], cex=0.5)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
758 # } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
759 # points(uri.n.list[[i]]$t.binned[1:jump.left.der[i]], uri.n.list[[i]]$uri.slope[1:jump.left.der[i]], col=col.txt[i+col.start], cex=0.5)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
760 # }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
761 lines(uri.n.list[[i]]$uri.der, col=col.txt[i+col.start], lwd=4)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
762 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
763 abline(h=1, lty=3)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
764 legend(0.5*max.peak, 1.5, legend=legend.txt, col=col.txt[(col.start+1):length(col.txt)], lty=1, lwd=3, cex=2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
765
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
766 if(!is.null(title))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
767 title(title.txt)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
768
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
769 if(!is.null(file.name)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
770 dev.off()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
771 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
772
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
773 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
774
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
775
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
776
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
777 #######################
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
778 ####################### copula fitting for matched peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
779 #######################
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
780
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
781 # estimation from mixed copula model
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
782
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
783 # 4-5-09
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
784 # A nonparametric estimation of mixed copula model
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
785
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
786
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
787 # updated
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
788
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
789 # c1, c2, f1, f2, g1, g2 are vectors
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
790 # c1*f1*g1 and c2*f2*g2 are copula densities for the two components
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
791 # xd1 and yd1 are the values of marginals for the first component
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
792 # xd2 and yd2 are the values of marginals for the 2nd component
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
793 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
794 # ez is the prob for being in the consistent group
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
795 get.ez <- function(p, c1, c2, xd1, yd1, xd2, yd2){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
796
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
797 return(p*c1*xd1*yd1/(p*c1*xd1*yd1 + (1-p)*c2*xd2*yd2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
798 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
799
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
800 # checked
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
801
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
802 # this is C_12 not the copula density function c=C_12 * f1* f2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
803 # since nonparametric estimation is used here for f1 and f2, which
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
804 # are constant throughout the iterations, we don't need them for optimization
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
805 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
806 # bivariate gaussian copula function
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
807 # t and s are vectors of same length, both are percentiles
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
808 # return a vector
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
809 gaussian.cop.den <- function(t, s, rho){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
810
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
811 A <- qnorm(t)^2 + qnorm(s)^2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
812 B <- qnorm(t)*qnorm(s)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
813
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
814 loglik <- -log(1-rho^2)/2 - rho/(2*(1-rho^2))*(rho*A-2*B)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
815
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
816 return(exp(loglik))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
817 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
818
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
819 clayton.cop.den <- function(t, s, rho){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
820
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
821 if(rho > 0)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
822 return(exp(log(rho+1)-(rho+1)*(log(t)+log(s))-(2+1/rho)*log(t^(-rho) + s^(-rho)-1)))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
823
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
824 if(rho==0)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
825 return(1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
826
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
827 if(rho<0)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
828 stop("Incorrect Clayton copula coefficient")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
829
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
830 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
831
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
832
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
833 # checked
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
834 # estimate rho from Gaussian copula
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
835 mle.gaussian.copula <- function(t, s, e.z){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
836
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
837 # reparameterize to bound from rho=+-1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
838 l.c <- function(rho, t, s, e.z){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
839 # cat("rho=", rho, "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
840 sum(e.z*log(gaussian.cop.den(t, s, rho)))}
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
841
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
842 rho.max <- optimize(f=l.c, c(-0.998, 0.998), maximum=T, tol=0.00001, t=t, s=s, e.z=e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
843
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
844 #print(rho.max$m)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
845
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
846 #cat("cor=", cor(qnorm(t)*e.z, qnorm(s)*e.z), "\t", "rho.max=", rho.max$m, "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
847 # return(sign(rho.max$m)/(1+rho.max$m))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
848 return(rho.max$m)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
849 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
850
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
851
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
852 # estimate mle from Clayton copula,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
853 mle.clayton.copula <- function(t, s, e.z){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
854
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
855 l.c <- function(rho, t, s, e.z){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
856 lc <- sum(e.z*log(clayton.cop.den(t, s, rho)))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
857 # cat("rho=", rho, "\t", "l.c=", lc, "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
858 return(lc)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
859 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
860
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
861 rho.max <- optimize(f=l.c, c(0.1, 20), maximum=T, tol=0.00001, t=t, s=s, e.z=e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
862
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
863 return(rho.max$m)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
864 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
865
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
866
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
867
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
868 # updated
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
869 # mixture likelihood of two gaussian copula
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
870 # nonparametric and ranked transformed
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
871 loglik.2gaussian.copula <- function(x, y, p, rho1, rho2, x.mar, y.mar){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
872
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
873 px.1 <- get.pdf.cdf(x, x.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
874 px.2 <- get.pdf.cdf(x, x.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
875 py.1 <- get.pdf.cdf(y, y.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
876 py.2 <- get.pdf.cdf(y, y.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
877
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
878 c1 <- gaussian.cop.den(px.1$cdf, py.1$cdf, rho1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
879 c2 <- gaussian.cop.den(px.2$cdf, py.2$cdf, rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
880
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
881 sum(log(p*c1*px.1$pdf*py.1$pdf + (1-p)*c2*px.2$pdf*py.2$pdf))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
882 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
883
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
884 loglik.2copula <- function(x, y, p, rho1, rho2, x.mar, y.mar, copula.txt){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
885
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
886 px.1 <- pdf.cdf$px.1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
887 px.2 <- pdf.cdf$px.2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
888 py.1 <- pdf.cdf$py.1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
889 py.2 <- pdf.cdf$py.2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
890
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
891 if(copula.txt=="gaussian"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
892 c1 <- gaussian.cop.den(px.1$cdf, py.1$cdf, rho1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
893 c2 <- gaussian.cop.den(px.2$cdf, py.2$cdf, rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
894 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
895 if(copula.txt=="clayton"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
896 c1 <- clayton.cop.den(px.1$cdf, py.1$cdf, rho1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
897 c2 <- clayton.cop.den(px.2$cdf, py.2$cdf, rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
898 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
899 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
900 sum(log(p*c1*px.1$pdf*py.1$pdf + (1-p)*c2*px.2$pdf*py.2$pdf))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
901 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
902
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
903
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
904 # estimate the marginals of each component using histogram estimator in EM
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
905 # return the density, breaks, and cdf of the histogram estimator
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
906 est.mar.hist <- function(x, e.z, breaks){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
907
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
908 binwidth <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
909 nbin <- length(breaks)-1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
910 nx <- length(x)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
911
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
912 # the histogram
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
913 x1.pdf <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
914 x2.pdf <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
915 x1.cdf <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
916 x2.cdf <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
917
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
918 # the pdf for each point
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
919 x1.pdf.value <- rep(NA, nx)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
920 x2.pdf.value <- rep(NA, nx)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
921
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
922 x1.cdf.value <- rep(NA, nx)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
923 x2.cdf.value <- rep(NA, nx)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
924
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
925 for(i in 1:nbin){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
926
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
927 binwidth[i] <- breaks[i+1] - breaks[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
928 if(i < nbin)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
929 in.bin <- x>= breaks[i] & x < breaks[i+1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
930 else # last bin
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
931 in.bin <- x>= breaks[i] & x <=breaks[i+1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
932
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
933 # each bin add one observation to avoid empty bins
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
934 # multiple (nx+nbin)/(nx+nbin+1) to avoid blowup when looking up for
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
935 # quantiles
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
936 x1.pdf[i] <- (sum(e.z[in.bin])+1)/(sum(e.z)+nbin)/binwidth[i]*(nx+nbin)/(nx+nbin+1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
937 x2.pdf[i] <- (sum(1-e.z[in.bin])+1)/(sum(1-e.z)+nbin)/binwidth[i]*(nx+nbin)/(nx+nbin+1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
938
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
939
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
940 # x1.pdf[i] <- sum(e.z[in.bin])/sum(e.z)/binwidth[i]*nx/(nx+1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
941 # x2.pdf[i] <- sum(1-e.z[in.bin])/sum(1-e.z)/binwidth[i]*nx/(nx+1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
942
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
943 # treat each bin as a value for a discrete variable
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
944 # x1.cdf[i] <- sum(x1.pdf[1:i]*binwidth[1:i])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
945 # x2.cdf[i] <- sum(x2.pdf[1:i]*binwidth[1:i])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
946
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
947
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
948 # cumulative density before reaching i
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
949 if(i>1){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
950 x1.cdf[i] <- sum(x1.pdf[1:(i-1)]*binwidth[1:(i-1)])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
951 x2.cdf[i] <- sum(x2.pdf[1:(i-1)]*binwidth[1:(i-1)])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
952 } else{
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
953 x1.cdf[i] <- 0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
954 x2.cdf[i] <- 0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
955 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
956
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
957 # make a vector of nx to store the values of pdf and cdf for each x
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
958 # this will speed up the computation dramatically
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
959 x1.pdf.value[in.bin] <- x1.pdf[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
960 x2.pdf.value[in.bin] <- x2.pdf[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
961
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
962 x1.cdf.value[in.bin] <- x1.cdf[i] + x1.pdf[i]*(x[in.bin]-breaks[i])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
963 x2.cdf.value[in.bin] <- x2.cdf[i] + x2.pdf[i]*(x[in.bin]-breaks[i])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
964 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
965
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
966 # x1.cdf <- cumsum(x1.pdf*binwidth)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
967 # x2.cdf <- cumsum(x2.pdf*binwidth)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
968
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
969 f1 <-list(breaks=breaks, density=x1.pdf, cdf=x1.cdf)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
970 f2 <-list(breaks=breaks, density=x2.pdf, cdf=x2.cdf)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
971
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
972 f1.value <- list(pdf=x1.pdf.value, cdf=x1.cdf.value)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
973 f2.value <- list(pdf=x2.pdf.value, cdf=x2.cdf.value)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
974
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
975 return(list(f1=f1, f2=f2, f1.value=f1.value, f2.value=f2.value))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
976 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
977
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
978 # estimate the marginal cdf from rank
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
979 est.cdf.rank <- function(x, conf.z){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
980
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
981 # add 1 to prevent blow up
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
982 x1.cdf <- rank(x[conf.z==1])/(length(x[conf.z==1])+1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
983
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
984 x2.cdf <- rank(x[conf.z==0])/(length(x[conf.z==0])+1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
985
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
986 return(list(cdf1=x1.cdf, cdf2=x2.cdf))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
987 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
988
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
989 # df is a density function with fields: density, cdf and breaks, x is a scalar
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
990 get.pdf <- function(x, df){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
991
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
992 if(x < df$breaks[1])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
993 cat("x is out of the range of df\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
994
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
995 index <- which(df$breaks >= x)[1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
996
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
997 if(index==1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
998 index <- index +1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
999 return(df$density[index-1])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1000 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1001
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1002 # get cdf from histgram estimator for a single value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1003 get.cdf <- function(x, df){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1004
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1005 index <- which(df$breaks >= x)[1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1006 if(index==1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1007 index <- index +1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1008 return(df$cdf[index-1])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1009 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1010
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1011 # df is a density function with fields: density, cdf and breaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1012 get.pdf.cdf <- function(x.vec, df){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1013
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1014 x.pdf <- sapply(x.vec, get.pdf, df=df)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1015 x.cdf <- sapply(x.vec, get.cdf, df=df)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1016 return(list(cdf=x.cdf, pdf=x.pdf))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1017 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1018
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1019 # E-step
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1020 # x and y are the original observations or ranks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1021 # rho1 and rho2 are the parameters of each copula
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1022 # f1, f2, g1, g2 are functions, each is a histogram
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1023 e.step.2gaussian <- function(x, y, p, rho1, rho2, x.mar, y.mar){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1024
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1025 # get pdf and cdf of each component from functions in the corresponding component
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1026 px.1 <- get.pdf.cdf(x, x.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1027 px.2 <- get.pdf.cdf(x, x.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1028 py.1 <- get.pdf.cdf(y, y.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1029 py.2 <- get.pdf.cdf(y, y.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1030
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1031 c1 <- gaussian.cop.den(px.1$cdf, py.1$cdf, rho1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1032 c2 <- gaussian.cop.den(px.2$cdf, py.2$cdf, rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1033
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1034 return(get.ez(p, c1, c2, px.1$pdf, py.1$pdf, px.2$pdf, py.2$pdf))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1035 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1036
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1037 # E-step
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1038 # rho1 and rho2 are the parameters of each copula
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1039 e.step.2copula <- function(x, y, p, rho1, rho2, x.mar, y.mar, copula.txt){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1040
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1041 # get pdf and cdf of each component from functions in the corresponding component
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1042 px.1 <- get.pdf.cdf(x, x.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1043 px.2 <- get.pdf.cdf(x, x.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1044 py.1 <- get.pdf.cdf(y, y.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1045 py.2 <- get.pdf.cdf(y, y.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1046
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1047 if(copula.txt=="gaussian"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1048 c1 <- gaussian.cop.den(px.1$cdf, py.1$cdf, rho1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1049 c2 <- gaussian.cop.den(px.2$cdf, py.2$cdf, rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1050 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1051 if(copula.txt=="clayton"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1052 c1 <- clayton.cop.den(px.1$cdf, py.1$cdf, rho1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1053 c2 <- clayton.cop.den(px.2$cdf, py.2$cdf, rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1054 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1055 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1056 return(get.ez(p, c1, c2, px.1$pdf, py.1$pdf, px.2$pdf, py.2$pdf))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1057 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1058
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1059
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1060
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1061
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1062 # M-step
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1063 m.step.2gaussian <- function(x, y, e.z, breaks){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1064
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1065 # compute f1, f2, g1 and g2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1066 x.mar <- est.mar.hist(x, e.z, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1067 y.mar <- est.mar.hist(y, e.z, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1068
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1069 px.1 <- get.pdf.cdf(x, x.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1070 px.2 <- get.pdf.cdf(x, x.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1071 py.1 <- get.pdf.cdf(y, y.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1072 py.2 <- get.pdf.cdf(y, y.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1073
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1074 rho1 <- mle.gaussian.copula(px.1$cdf, py.1$cdf, e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1075 rho2 <- mle.gaussian.copula(px.2$cdf, py.2$cdf, 1-e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1076
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1077 p <- sum(e.z)/length(e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1078
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1079 return(list(p=p, rho1=rho1, rho2=rho2, x.mar=x.mar, y.mar=y.mar))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1080 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1081
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1082 m.step.2copula <- function(x, y, e.z, breaks, copula.txt){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1083
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1084 # compute f1, f2, g1 and g2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1085 x.mar <- est.mar.hist(x, e.z, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1086 y.mar <- est.mar.hist(y, e.z, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1087
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1088 px.1 <- get.pdf.cdf(x, x.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1089 px.2 <- get.pdf.cdf(x, x.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1090 py.1 <- get.pdf.cdf(y, y.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1091 py.2 <- get.pdf.cdf(y, y.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1092
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1093 if(copula.txt=="gaussian"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1094 rho1 <- mle.gaussian.copula(px.1$cdf, py.1$cdf, e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1095 rho2 <- mle.gaussian.copula(px.2$cdf, py.2$cdf, 1-e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1096 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1097 if(copula.txt=="clayton"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1098 rho1 <- mle.clayton.copula(px.1$cdf, py.1$cdf, e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1099 rho2 <- mle.clayton.copula(px.2$cdf, py.2$cdf, 1-e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1100 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1101 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1102
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1103 p <- sum(e.z)/length(e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1104
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1105 return(list(p=p, rho1=rho1, rho2=rho2, x.mar=x.mar, y.mar=y.mar))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1106 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1107
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1108
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1109
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1110 # E-step: pass values
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1111 # x and y are the original observations or ranks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1112 # rho1 and rho2 are the parameters of each copula
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1113 # f1, f2, g1, g2 are functions, each is a histogram
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1114 e.step.2gaussian.value <- function(x, y, p, rho1, rho2, pdf.cdf){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1115
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1116 c1 <- gaussian.cop.den(pdf.cdf$px.1$cdf, pdf.cdf$py.1$cdf, rho1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1117 c2 <- gaussian.cop.den(pdf.cdf$px.2$cdf, pdf.cdf$py.2$cdf, rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1118
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1119 e.z <- get.ez(p, c1, c2, pdf.cdf$px.1$pdf, pdf.cdf$py.1$pdf,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1120 pdf.cdf$px.2$pdf, pdf.cdf$py.2$pdf)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1121 return(e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1122 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1123
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1124
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1125 e.step.2copula.value <- function(x, y, p, rho1, rho2, pdf.cdf, copula.txt){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1126
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1127 if(copula.txt =="gaussian"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1128 c1 <- gaussian.cop.den(pdf.cdf$px.1$cdf, pdf.cdf$py.1$cdf, rho1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1129 c2 <- gaussian.cop.den(pdf.cdf$px.2$cdf, pdf.cdf$py.2$cdf, rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1130 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1131 if(copula.txt =="clayton"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1132 c1 <- clayton.cop.den(pdf.cdf$px.1$cdf, pdf.cdf$py.1$cdf, rho1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1133 c2 <- clayton.cop.den(pdf.cdf$px.2$cdf, pdf.cdf$py.2$cdf, rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1134 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1135 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1136
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1137 e.z <- get.ez(p, c1, c2, pdf.cdf$px.1$pdf, pdf.cdf$py.1$pdf,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1138 pdf.cdf$px.2$pdf, pdf.cdf$py.2$pdf)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1139 return(e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1140 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1141
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1142
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1143 # M-step: pass values
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1144 m.step.2gaussian.value <- function(x, y, e.z, breaks, fix.rho2){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1145
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1146 # compute f1, f2, g1 and g2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1147 x.mar <- est.mar.hist(x, e.z, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1148 y.mar <- est.mar.hist(y, e.z, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1149
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1150 # px.1 <- get.pdf.cdf(x, x.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1151 # px.2 <- get.pdf.cdf(x, x.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1152 # py.1 <- get.pdf.cdf(y, y.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1153 # py.2 <- get.pdf.cdf(y, y.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1154
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1155 px.1 <- x.mar$f1.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1156 px.2 <- x.mar$f2.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1157 py.1 <- y.mar$f1.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1158 py.2 <- y.mar$f2.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1159
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1160 rho1 <- mle.gaussian.copula(px.1$cdf, py.1$cdf, e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1161
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1162 if(!fix.rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1163 rho2 <- mle.gaussian.copula(px.2$cdf, py.2$cdf, 1-e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1164 else
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1165 rho2 <- 0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1166
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1167 p <- sum(e.z)/length(e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1168
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1169 pdf.cdf <- list(px.1=px.1, px.2=px.2, py.1=py.1, py.2=py.2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1170
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1171 return(list(p=p, rho1=rho1, rho2=rho2, x.mar=x.mar, y.mar=y.mar,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1172 pdf.cdf=pdf.cdf))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1173 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1174
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1175 m.step.2gaussian.value2 <- function(x, y, e.z, breaks, fix.rho2, x.mar, y.mar){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1176
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1177 # compute f1, f2, g1 and g2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1178 # x.mar <- est.mar.hist(x, e.z, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1179 # y.mar <- est.mar.hist(y, e.z, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1180
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1181 # px.1 <- get.pdf.cdf(x, x.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1182 # px.2 <- get.pdf.cdf(x, x.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1183 # py.1 <- get.pdf.cdf(y, y.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1184 # py.2 <- get.pdf.cdf(y, y.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1185
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1186 px.1 <- x.mar$f1.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1187 px.2 <- x.mar$f2.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1188 py.1 <- y.mar$f1.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1189 py.2 <- y.mar$f2.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1190
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1191 rho1 <- mle.gaussian.copula(px.1$cdf, py.1$cdf, e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1192
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1193 if(!fix.rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1194 rho2 <- mle.gaussian.copula(px.2$cdf, py.2$cdf, 1-e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1195 else
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1196 rho2 <- 0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1197
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1198 p <- sum(e.z)/length(e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1199
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1200 pdf.cdf <- list(px.1=px.1, px.2=px.2, py.1=py.1, py.2=py.2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1201
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1202 return(list(p=p, rho1=rho1, rho2=rho2, x.mar=x.mar, y.mar=y.mar,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1203 pdf.cdf=pdf.cdf))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1204 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1205
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1206
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1207
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1208 m.step.2copula.value <- function(x, y, e.z, breaks, fix.rho2, copula.txt){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1209
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1210 # compute f1, f2, g1 and g2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1211 x.mar <- est.mar.hist(x, e.z, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1212 y.mar <- est.mar.hist(y, e.z, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1213
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1214 # px.1 <- get.pdf.cdf(x, x.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1215 # px.2 <- get.pdf.cdf(x, x.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1216 # py.1 <- get.pdf.cdf(y, y.mar$f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1217 # py.2 <- get.pdf.cdf(y, y.mar$f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1218
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1219 px.1 <- x.mar$f1.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1220 px.2 <- x.mar$f2.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1221 py.1 <- y.mar$f1.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1222 py.2 <- y.mar$f2.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1223
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1224 if(copula.txt=="gaussian"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1225 rho1 <- mle.gaussian.copula(px.1$cdf, py.1$cdf, e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1226
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1227 if(!fix.rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1228 rho2 <- mle.gaussian.copula(px.2$cdf, py.2$cdf, 1-e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1229 else
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1230 rho2 <- 0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1231 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1232
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1233 if(copula.txt=="clayton"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1234 rho1 <- mle.clayton.copula(px.1$cdf, py.1$cdf, e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1235
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1236 if(!fix.rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1237 rho2 <- mle.clayton.copula(px.2$cdf, py.2$cdf, 1-e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1238 else
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1239 rho2 <- 0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1240 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1241 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1242
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1243 p <- sum(e.z)/length(e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1244
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1245 pdf.cdf <- list(px.1=px.1, px.2=px.2, py.1=py.1, py.2=py.2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1246
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1247 return(list(p=p, rho1=rho1, rho2=rho2, x.mar=x.mar, y.mar=y.mar,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1248 pdf.cdf=pdf.cdf))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1249 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1250
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1251
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1252
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1253
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1254 # updated
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1255 # mixture likelihood of two gaussian copula
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1256 # nonparametric and ranked transformed
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1257 loglik.2gaussian.copula.value <- function(x, y, p, rho1, rho2, pdf.cdf){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1258
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1259 px.1 <- pdf.cdf$px.1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1260 px.2 <- pdf.cdf$px.2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1261 py.1 <- pdf.cdf$py.1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1262 py.2 <- pdf.cdf$py.2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1263
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1264 c1 <- gaussian.cop.den(px.1$cdf, py.1$cdf, rho1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1265 c2 <- gaussian.cop.den(px.2$cdf, py.2$cdf, rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1266
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1267 sum(log(p*c1*px.1$pdf*py.1$pdf + (1-p)*c2*px.2$pdf*py.2$pdf))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1268 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1269
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1270
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1271
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1272 # updated
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1273 # mixture likelihood of two gaussian copula
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1274 # nonparametric and ranked transformed
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1275 loglik.2copula.value <- function(x, y, p, rho1, rho2, pdf.cdf, copula.txt){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1276
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1277 px.1 <- pdf.cdf$px.1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1278 px.2 <- pdf.cdf$px.2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1279 py.1 <- pdf.cdf$py.1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1280 py.2 <- pdf.cdf$py.2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1281
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1282 if(copula.txt=="gaussian"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1283 c1 <- gaussian.cop.den(px.1$cdf, py.1$cdf, rho1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1284 c2 <- gaussian.cop.den(px.2$cdf, py.2$cdf, rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1285 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1286 if(copula.txt=="clayton"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1287 c1 <- clayton.cop.den(px.1$cdf, py.1$cdf, rho1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1288 c2 <- clayton.cop.den(px.2$cdf, py.2$cdf, rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1289 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1290 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1291
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1292 sum(log(p*c1*px.1$pdf*py.1$pdf + (1-p)*c2*px.2$pdf*py.2$pdf))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1293 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1294
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1295
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1296
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1297 # EM for 2 Gaussian, speed up computation, unfinished
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1298
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1299 em.2gaussian.quick <- function(x, y, p0, rho1.0, rho2.0, eps, fix.p=F, stoc=T, fix.rho2=T){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1300
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1301 x <- rank(x, tie="random")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1302 y <- rank(y, tie="random")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1303
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1304 # x <- rank(x, tie="average")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1305 # y <- rank(y, tie="average")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1306
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1307 # nbin=20
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1308 xy.min <- min(x, y)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1309 xy.max <- max(x, y)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1310 binwidth <- (xy.max-xy.min)/50
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1311 breaks <- seq(xy.min-binwidth/100, xy.max+binwidth/100, by=(xy.max-xy.min+binwidth/50)/50)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1312 # breaks <- seq(xy.min, xy.max, by=binwidth)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1313
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1314
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1315 # initiate marginals
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1316 # initialization: first p0 data has
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1317 # e.z <- e.step.2gaussian(x, y, p0, rho1.0, rho2.0, x0.mar, y0.mar) # this starting point assumes two components are overlapped
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1318
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1319 e.z <- c(rep(0.9, round(length(x)*p0)), rep(0.1, length(x)-round(length(x)*p0)))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1320
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1321 if(!stoc)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1322 para <- m.step.2gaussian.value(x, y, e.z, breaks, fix.rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1323 else
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1324 para <- m.step.2gaussian.stoc.value(x, y, e.z, breaks, fix.rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1325
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1326
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1327 if(fix.p){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1328 p <- p0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1329 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1330 p <- para$p
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1331 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1332
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1333 if(fix.rho2){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1334 rho2 <- rho2.0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1335 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1336 rho2 <- para$rho2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1337 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1338
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1339 # rho1 <- 0.8
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1340 rho1 <- para$rho1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1341
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1342 l0 <- loglik.2gaussian.copula.value(x, y, p, rho1, rho2, para$pdf.cdf)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1343
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1344 loglik.trace <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1345 loglik.trace[1] <- l0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1346 # loglik.trace[2] <- l1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1347 to.run <- T
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1348
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1349 i <- 2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1350
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1351 # this two lines to remove
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1352 # x.mar <- est.mar.hist(x, e.z, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1353 # y.mar <- est.mar.hist(y, e.z, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1354
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1355 while(to.run){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1356
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1357 e.z <- e.step.2gaussian.value(x, y, p, rho1, rho2, para$pdf.cdf)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1358 if(!stoc)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1359 para <- m.step.2gaussian.value(x, y, e.z, breaks, fix.rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1360 else
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1361 para <- m.step.2gaussian.stoc.value(x, y, e.z, breaks, fix.rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1362
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1363 # fix x.mar and y.mar : to remove
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1364 # if(!stoc)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1365 # para <- m.step.2gaussian.value2(x, y, e.z, breaks, fix.rho2, x.mar, y.mar)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1366 # else
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1367 # para <- m.step.2gaussian.stoc.value(x, y, e.z, breaks, fix.rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1368
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1369
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1370 if(fix.p){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1371 p <- p0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1372 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1373 p <- para$p
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1374 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1375
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1376 if(fix.rho2){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1377 rho2 <- rho2.0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1378 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1379 rho2 <- para$rho2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1380 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1381
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1382 # rho1 <- 0.8
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1383 rho1 <- para$rho1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1384
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1385 # l0 <- l1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1386 l1 <- loglik.2gaussian.copula.value(x, y, p, rho1, rho2, para$pdf.cdf)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1387 loglik.trace[i] <- l1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1388
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1389 #cat("l1=", l1, "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1390
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1391 # Aitken acceleration criterion
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1392 if(i > 2){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1393 l.inf <- loglik.trace[i-2] + (loglik.trace[i-1] - loglik.trace[i-2])/(1-(loglik.trace[i]-loglik.trace[i-1])/(loglik.trace[i-1]-loglik.trace[i-2]))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1394 to.run <- abs(l.inf - loglik.trace[i]) > eps
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1395 #cat("para=", "p=", para$p, " rho1=", rho1, " rho2=", rho2, "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1396 #cat("l.inf=", l.inf, "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1397 #cat(l.inf-loglik.trace[i], "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1398 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1399
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1400 i <- i+1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1401 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1402
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1403 bic <- -2*l1 + (2*(length(breaks)-1+1)+1-fix.p-fix.rho2)*log(length(x)) # parameters
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1404 return(list(para=list(p=para$p, rho1=rho1, rho2=rho2),
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1405 loglik=l1, bic=bic, e.z=e.z, conf.z = para$conf.z,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1406 loglik.trace=loglik.trace, x.mar=para$x.mar, y.mar=para$y.mar,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1407 breaks=breaks))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1408 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1409
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1410
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1411
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1412 em.2copula.quick <- function(x, y, p0, rho1.0, rho2.0, eps, fix.p=F, stoc=T, fix.rho2=T, copula.txt, nbin=50){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1413
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1414 x <- rank(x, tie="random")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1415 y <- rank(y, tie="random")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1416
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1417 # x <- rank(x, tie="first")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1418 # y <- rank(y, tie="first")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1419
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1420 # nbin=50
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1421 xy.min <- min(x, y)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1422 xy.max <- max(x, y)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1423 binwidth <- (xy.max-xy.min)/50
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1424 breaks <- seq(xy.min-binwidth/100, xy.max+binwidth/100, by=(xy.max-xy.min+binwidth/50)/nbin)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1425 # breaks <- seq(xy.min, xy.max, by=binwidth)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1426
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1427 # initiate marginals
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1428 # initialization: first p0 data has
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1429 # e.z <- e.step.2gaussian(x, y, p0, rho1.0, rho2.0, x0.mar, y0.mar) # this starting point assumes two components are overlapped
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1430
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1431 e.z <- c(rep(0.9, round(length(x)*p0)), rep(0.1, length(x)-round(length(x)*p0)))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1432
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1433
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1434 if(!stoc)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1435 para <- m.step.2copula.value(x, y, e.z, breaks, fix.rho2, copula.txt)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1436 else
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1437 para <- m.step.2copula.stoc.value(x, y, e.z, breaks, fix.rho2, copula.txt)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1438
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1439 if(fix.p){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1440 p <- p0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1441 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1442 p <- para$p
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1443 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1444
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1445 if(fix.rho2){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1446 rho2 <- rho2.0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1447 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1448 rho2 <- para$rho2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1449 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1450
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1451 l0 <- loglik.2copula.value(x, y, p, para$rho1, rho2, para$pdf.cdf, copula.txt)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1452
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1453 loglik.trace <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1454 loglik.trace[1] <- l0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1455 # loglik.trace[2] <- l1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1456 to.run <- T
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1457
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1458 i <- 2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1459
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1460 while(to.run){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1461
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1462 e.z <- e.step.2copula.value(x, y, p, para$rho1, rho2, para$pdf.cdf, copula.txt)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1463 if(!stoc)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1464 para <- m.step.2copula.value(x, y, e.z, breaks, fix.rho2, copula.txt)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1465 else
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1466 para <- m.step.2copula.stoc.value(x, y, e.z, breaks, fix.rho2, copula.txt)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1467
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1468 if(fix.p){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1469 p <- p0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1470 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1471 p <- para$p
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1472 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1473
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1474 if(fix.rho2){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1475 rho2 <- rho2.0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1476 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1477 rho2 <- para$rho2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1478 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1479
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1480
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1481 # l0 <- l1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1482 l1 <- loglik.2copula.value(x, y, p, para$rho1, rho2, para$pdf.cdf, copula.txt)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1483 loglik.trace[i] <- l1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1484
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1485 cat("l1=", l1, "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1486
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1487 # Aitken acceleration criterion
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1488 if(i > 2){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1489 l.inf <- loglik.trace[i-2] + (loglik.trace[i-1] - loglik.trace[i-2])/(1-(loglik.trace[i]-loglik.trace[i-1])/(loglik.trace[i-1]-loglik.trace[i-2]))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1490 to.run <- abs(l.inf - loglik.trace[i]) > eps
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1491 cat("para=", "p=", para$p, " rho1=", para$rho1, " rho2=", rho2, "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1492 #cat("l.inf=", l.inf, "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1493 #cat(l.inf-loglik.trace[i], "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1494 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1495
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1496 i <- i+1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1497 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1498
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1499 bic <- -2*l1 + (2*(length(breaks)-1+1)+1-fix.p-fix.rho2)*log(length(x)) # parameters
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1500 return(list(para=list(p=para$p, rho1=para$rho1, rho2=rho2),
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1501 loglik=l1, bic=bic, e.z=e.z, conf.z = para$conf.z,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1502 loglik.trace=loglik.trace, x.mar=para$x.mar, y.mar=para$y.mar,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1503 breaks=breaks))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1504 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1505
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1506
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1507 #######################
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1508 ####################### fit EM procedure for the matched peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1509 #######################
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1510
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1511 # remove the unmatched ones
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1512 #rm.unmatch <- function(sample1, sample2, p.value.impute=0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1513 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1514 # sample1.prune <- sample1[sample1$sig.value > p.value.impute & sample2$sig.value > p.value.impute,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1515 # sample2.prune <- sample2[sample1$sig.value > p.value.impute & sample2$sig.value > p.value.impute,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1516 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1517 # invisible(list(sample1=sample1.prune$sig.value, sample2=sample2.prune$sig.value))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1518 #}
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1519
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1520
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1521 # fit 2-component model
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1522 #fit.em <- function(sample12, fix.rho2=T){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1523 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1524 # prune.sample <- rm.unmatch(sample12$merge1, sample12$merge2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1525 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1526 # em.fit <- em.2gaussian.quick(-prune.sample$sample1, -prune.sample$sample2,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1527 # p0=0.5, rho1.0=0.7, rho2.0=0, eps=0.01, fix.p=F, stoc=F, fix.rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1528 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1529 # invisible(list(em.fit=em.fit, data.pruned=prune.sample))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1530 #}
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1531
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1532
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1533 rm.unmatch <- function(sample1, sample2, p.value.impute=0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1534
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1535 sample1.prune <- sample1[sample1$sig.value > p.value.impute & sample2$sig.value > p.value.impute,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1536 sample2.prune <- sample2[sample1$sig.value > p.value.impute & sample2$sig.value > p.value.impute,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1537
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1538 invisible(list(sample1=sample1.prune, sample2=sample2.prune))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1539 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1540
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1541
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1542 # fit 2-component model
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1543 fit.em <- function(sample12, fix.rho2=T){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1544
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1545 prune.sample <- rm.unmatch(sample12$merge1, sample12$merge2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1546
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1547 em.fit <- em.2gaussian.quick(-prune.sample$sample1$sig.value, -prune.sample$sample2$sig.value,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1548 p0=0.5, rho1.0=0.7, rho2.0=0, eps=0.01, fix.p=F, stoc=F, fix.rho2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1549
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1550 invisible(list(em.fit=em.fit, data.pruned=prune.sample))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1551 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1552
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1553
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1554
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1555 fit.2copula.em <- function(sample12, fix.rho2=T, copula.txt){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1556
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1557 prune.sample <- rm.unmatch(sample12$merge1, sample12$merge2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1558
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1559 # o <- order(prune.sample$sample1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1560 # n <- length(prune.sample$sample1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1561
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1562 # para <- init(prune.sample$sample1$sig.value, prune.sample$sample2$sig.value, c(rep(0, round(n/3)), rep(c(0,1), round(n/6)), rep(1, n-round(n/3)-round(n/6))))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1563
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1564 # temp <- init.dist(f0, f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1565 para <- list()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1566 para$rho <- 0.6
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1567 para$p <- 0.3
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1568 para$mu <- 2.5
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1569 para$sigma <- 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1570 ## para$mu <- -temp$mu
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1571 ## para$sigma <- temp$sigma
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1572 #cat("mu=", para$mu, "sigma=", para$sigma, "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1573
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1574 # em.fit <- em.transform.1loop(-prune.sample$sample1, -prune.sample$sample2,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1575 cat("EM is running")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1576 em.fit <- em.transform(prune.sample$sample1$sig.value, prune.sample$sample2$sig.value, para$mu, para$sigma, para$rho, para$p, eps=0.01)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1577
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1578 invisible(list(em.fit=em.fit, data.pruned=prune.sample))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1579 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1580
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1581
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1582
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1583
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1584 # fit 1-component model
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1585 fit.1.component <- function(data.pruned, breaks){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1586
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1587 # gaussian.1 <- fit.gaussian.1(-data.pruned$sample1$sig.value, -data.pruned$sample2$sig.value, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1588 # clayton.1 <- fit.clayton.1(-data.pruned$sample1$sig.value, -data.pruned$sample2$sig.value, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1589
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1590 gaussian.1 <- fit.gaussian.1(-data.pruned$sample1, -data.pruned$sample2, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1591 clayton.1 <- fit.clayton.1(-data.pruned$sample1, -data.pruned$sample2, breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1592
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1593 return(list(gaussian.1=gaussian.1, clayton.1=clayton.1))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1594 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1595
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1596
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1597
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1598 #################
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1599 # Fit a single component
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1600 #################
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1601
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1602 # a single gaussian copula
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1603 # if breaks=NULL, use empirical pdf, otherwise use histogram estimate
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1604 fit.gaussian.1 <- function(x, y, breaks=NULL){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1605
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1606 # rank transformed and compute the empirical cdf
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1607 t <- emp.mar.cdf.rank(x)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1608 s <- emp.mar.cdf.rank(y)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1609
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1610 mle.rho <- mle.gaussian.copula(t, s, rep(1, length(t)))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1611
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1612 c1 <- gaussian.cop.den(t, s, mle.rho)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1613 cat("c1", sum(log(c1)), "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1614
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1615 if(is.null(breaks)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1616 f1 <- emp.mar.pdf.rank(t)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1617 f2 <- emp.mar.pdf.rank(s)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1618 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1619 x.mar <- est.mar.hist(rank(x), rep(1, length(x)), breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1620 y.mar <- est.mar.hist(rank(y), rep(1, length(y)), breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1621
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1622 f1 <- x.mar$f1.value$pdf # only one component
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1623 f2 <- y.mar$f1.value$pdf
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1624 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1625
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1626
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1627 cat("f1", sum(log(f1)), "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1628 cat("f2", sum(log(f2)), "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1629
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1630 loglik <- sum(log(c1)+log(f1)+log(f2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1631
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1632 bic <- -2*loglik + log(length(t))*(1+length(breaks)-1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1633
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1634 return(list(rho=mle.rho, loglik=loglik, bic=bic))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1635 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1636
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1637
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1638 # a single Clayton copula
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1639 fit.clayton.1 <- function(x, y, breaks=NULL){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1640
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1641 # rank transformed and compute the empirical cdf
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1642 t <- emp.mar.cdf.rank(x)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1643 s <- emp.mar.cdf.rank(y)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1644
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1645 mle.rho <- mle.clayton.copula(t, s, rep(1, length(t)))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1646
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1647 c1 <- clayton.cop.den(t, s, mle.rho)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1648
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1649 if(is.null(breaks)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1650 f1 <- emp.mar.pdf.rank(t)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1651 f2 <- emp.mar.pdf.rank(s)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1652 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1653 x.mar <- est.mar.hist(rank(x), rep(1, length(x)), breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1654 y.mar <- est.mar.hist(rank(y), rep(1, length(y)), breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1655
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1656 f1 <- x.mar$f1.value$pdf # only one component
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1657 f2 <- y.mar$f1.value$pdf
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1658 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1659
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1660 loglik <- sum(log(c1)+log(f1)+log(f2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1661
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1662 bic <- -2*loglik + log(length(t))*(1+length(breaks)-1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1663
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1664 return(list(rho=mle.rho, tau=rho/(rho+2), loglik=loglik, bic=bic))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1665 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1666
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1667 ## obsolete function (01-06-2010)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1668 ## compute the average posterior probability to belong to the random component
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1669 ## for peaks selected at different cutoffs
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1670 comp.uri.ez <- function(tt, u, v, e.z){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1671
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1672 u.t <- quantile(u, prob=(1-tt))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1673 v.t <- quantile(v, prob=(1-tt))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1674
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1675 # ez <- mean(e.z[u >= u.t & v >=u.t]) Is this wrong?
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1676 ez <- mean(e.z[u >= u.t & v >=v.t])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1677
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1678 return(ez)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1679 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1680
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1681 ## obsolete function (01-06-2010)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1682 # compute the largest posterior error probability corresponding to
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1683 # the square centered at the origin and spanned top tt% on both coordinates
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1684 # so the consistent low rank ones are excluded
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1685 # boundary.txt: either "max" or "min", if it is error prob, use "max"
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1686 comp.ez.cutoff <- function(tt, u, v, e.z, boundary.txt){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1687
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1688 u.t <- quantile(u, prob=(1-tt))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1689 v.t <- quantile(v, prob=(1-tt))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1690
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1691 if(boundary.txt == "max"){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1692 # ez.bound <- max(e.z[u >= u.t & v >=u.t])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1693 ez.bound <- max(e.z[u >= u.t & v >=v.t])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1694 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1695 # ez.bound <- min(e.z[u >= u.t & v >=u.t])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1696 ez.bound <- min(e.z[u >= u.t & v >=v.t])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1697 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1698
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1699 return(ez.bound)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1700
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1701 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1702
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1703 # obsolete functions: 01-06-2010
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1704 # compute the error rate
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1705 # u.t and v.t are the quantiles
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1706 # this one is used for the plots generated initially in the brief writeup
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1707 # and it was used for processing merged data in July before the IDR definition
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1708 # is formalized
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1709 # It does not implement the current definition of IDR
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1710 get.ez.tt.old <- function(em.fit, reverse=T, fdr.level=c(0.01, 0.05, 0.1)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1711
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1712 u <- em.fit$data.pruned$sample1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1713 v <- em.fit$data.pruned$sample2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1714
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1715 tt <- seq(0.01, 0.99, by=0.01)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1716 if(reverse){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1717 e.z <- 1-em.fit$em.fit$e.z # this is the error prob
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1718 uri.ez <- sapply(tt, comp.uri.ez, u=u, v=v, e.z=e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1719 ez.bound <- sapply(tt, comp.ez.cutoff, u=u, v=v, e.z=e.z, boundary.txt="max")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1720 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1721 e.z <- em.fit$em.fit$e.z
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1722 uri.ez <- sapply(tt, comp.uri.ez, u=u, v=v, e.z=e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1723 ez.bound <- sapply(tt, comp.ez.cutoff, u=u, v=v, e.z=e.z, boundary.txt="min")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1724 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1725
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1726 u.t <- quantile(u, prob=(1-tt))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1727 v.t <- quantile(v, prob=(1-tt))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1728
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1729 # find the levels on the two replicates
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1730 sig.value1 <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1731 sig.value2 <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1732 error.prob.cutoff <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1733 n.selected.match <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1734
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1735 for(i in 1:length(fdr.level)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1736
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1737 # find which uri.ez is closet to fdr.level
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1738 index <- which.min(abs(uri.ez - fdr.level[i]))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1739 sig.value1[i] <- u.t[index]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1740 sig.value2[i] <- v.t[index]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1741 error.prob.cutoff[i] <- ez.bound[index]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1742 if(reverse){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1743 n.selected.match[i] <- sum(e.z<=ez.bound[index])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1744 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1745 n.selected.match[i] <- sum(e.z>=ez.bound[index])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1746 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1747 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1748
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1749 # output the cutoff of posterior probability, signal values on two replicates
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1750 map.uv <- cbind(error.prob.cutoff, sig.value1, sig.value2, n.selected.match)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1751
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1752 return(list(n=tt*length(u), uri.ez=uri.ez, u.t=u.t, v.t=v.t, tt=tt, fdr.level=fdr.level, map.uv=map.uv, e.z=e.z, error.prob.cutoff=error.prob.cutoff))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1753 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1754
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1755 # created: 01-06-2010
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1756 # Output IDR at various number of selected peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1757 # Find cutoff (idr cutoff, sig.value cutoff on each replicate) for specified IDR level
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1758 # IDR definition is similar to FDR
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1759 get.ez.tt <- function(em.fit, idr.level=c(0.01, 0.05, 0.1)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1760
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1761 # u <- em.fit$data.pruned$sample1$sig.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1762 # v <- em.fit$data.pruned$sample2$sig.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1763 u <- em.fit$data.pruned$sample1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1764 v <- em.fit$data.pruned$sample2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1765
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1766 e.z <- 1-em.fit$em.fit$e.z # this is the error prob
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1767
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1768 o <- order(e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1769 e.z.ordered <- e.z[o]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1770 n.select <- c(1:length(e.z))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1771 IDR <- cumsum(e.z.ordered)/n.select
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1772
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1773 u.o <- u[o]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1774 v.o <- v[o]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1775
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1776 n.level <- length(idr.level)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1777 # sig.value1 <- rep(NA, n.level)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1778 # sig.value2 <- rep(NA, n.level)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1779 ez.cutoff <- rep(NA, n.level)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1780 n.selected <- rep(NA, n.level)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1781
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1782 for(i in 1:length(idr.level)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1783
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1784 # find which uri.ez is closet to fdr.level
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1785 index <- which.min(abs(IDR - idr.level[i]))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1786 # sig.value1[i] <- min(u.o[1:index])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1787 # sig.value2[i] <- min(v.o[1:index])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1788 ez.cutoff[i] <- e.z[index]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1789 n.selected[i] <- sum(e.z<=ez.cutoff[i])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1790 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1791
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1792 # output the cutoff of posterior probability, number of selected overlapped peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1793 # map.uv <- cbind(ez.cutoff, sig.value1, sig.value2, n.selected)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1794
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1795 map.uv <- cbind(ez.cutoff, n.selected)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1796
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1797 return(list(n=n.select, IDR=IDR, idr.level=idr.level, map.uv=map.uv))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1798 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1799
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1800 # return(list(n=tt*length(u), uri.ez=uri.ez, fdr.level=fdr.level, map.uv=map.uv, e.z=e.z, error.prob.cutoff=error.prob.cutoff))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1801
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1802
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1803
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1804
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1805
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1806 ### compute the mean of the marginals
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1807 get.mar.mean <- function(em.out){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1808
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1809 x.f1 <- em.out$x.mar$f1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1810 x.f2 <- em.out$x.mar$f2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1811
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1812 y.f1 <- em.out$y.mar$f1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1813 y.f2 <- em.out$y.mar$f2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1814
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1815 x.stat1 <- get.hist.mean(x.f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1816 x.stat2 <- get.hist.mean(x.f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1817 y.stat1 <- get.hist.mean(y.f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1818 y.stat2 <- get.hist.mean(y.f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1819
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1820 return(list(x.mean1=x.stat1$mean, x.mean2=x.stat2$mean,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1821 y.mean1=y.stat1$mean, y.mean2=y.stat2$mean,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1822 x.sd1=x.stat1$sd, x.sd2=x.stat2$sd,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1823 y.sd1=y.stat1$sd, y.sd2=y.stat2$sd
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1824 ))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1825
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1826 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1827
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1828
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1829 # compute the mean of marginals
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1830 get.hist.mean <- function(x.f){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1831
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1832 nbreaks <- length(x.f$breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1833 x.bin <- x.f$breaks[-1]-x.f$breaks[-nbreaks]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1834
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1835 x.mid <- (x.f$breaks[-nbreaks]+x.f$breaks[-1])/2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1836 x.mean <- sum(x.mid*x.f$density*x.bin)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1837 x.sd <- sqrt(sum(x.mid*x.mid*x.f$density*x.bin)-x.mean^2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1838
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1839 return(list(mean=x.mean, sd=x.sd))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1840 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1841
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1842 get.hist.var <- function(x.f){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1843
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1844 nbreaks <- length(x.f$breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1845 x.bin <- x.f$breaks[-1]-x.f$breaks[-nbreaks]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1846
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1847 x.mid <- (x.f$breaks[-nbreaks]+x.f$breaks[-1])/2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1848 x.mean <- sum(x.mid*x.f$density*x.bin)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1849
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1850 return(mean=x.mean)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1851 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1852
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1853 # obsolete function (01-06-2010)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1854 # plot
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1855 plot.ez.group.old <- function(ez.list, plot.dir, file.name=NULL, legend.txt, y.lim=NULL, xlab.txt="num of significant peaks", ylab.txt="avg posterior prob of being random", col.txt=NULL, title.txt=NULL){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1856
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1857 if(is.null(col.txt))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1858 col.txt <- c("black", "red", "purple", "green", "blue", "cyan", "magenta", "orange", "grey")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1859
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1860 x <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1861 y <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1862
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1863 for(i in 1:length(ez.list)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1864 x <- c(x, ez.list[[i]]$n)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1865
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1866 y <- c(y, ez.list[[i]]$uri.ez)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1867 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1868
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1869 if(is.null(y.lim))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1870 y.lim <- c(0, max(y))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1871
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1872 if(!is.null(file.name)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1873 postscript(paste(plot.dir, "ez.", file.name, sep=""))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1874 par(mfrow=c(1,1), mar=c(5,5,4,2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1875 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1876
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1877 plot(x, y, ylim=y.lim, type="n", xlab=xlab.txt, ylab=ylab.txt, lwd=5, cex=5, cex.axis=2, cex.lab=2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1878
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1879 for(i in 1:length(ez.list)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1880 lines(ez.list[[i]]$n, ez.list[[i]]$uri.ez, col=col.txt[i], cex=2, lwd=5)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1881 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1882
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1883 # plot(ez.list[[1]]$u.t, y, ylim=y.lim, type="l", xlab="rep-sig", ylab=ylab.txt, lwd=5, cex=5, cex.axis=2, cex.lab=2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1884 # plot(ez.list[[1]]$v.t, y, ylim=y.lim, type="l", xlab="rep-sig", ylab=ylab.txt, lwd=5, cex=5, cex.axis=2, cex.lab=2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1885
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1886
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1887 legend(0, y.lim[2], legend=legend.txt, col=col.txt[1:length(col.txt)], lty=1, lwd=5, cex=2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1888
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1889 if(!is.null(title))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1890 title(title.txt)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1891
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1892 if(!is.null(file.name)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1893 dev.off()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1894 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1895
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1896 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1897
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1898
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1899 plot.ez.group <- function(ez.list, plot.dir, file.name=NULL, legend.txt, y.lim=NULL, xlab.txt="num of significant peaks", ylab.txt="IDR", col.txt=NULL, title.txt=NULL){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1900
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1901 if(is.null(col.txt))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1902 col.txt <- c("black", "red", "purple", "green", "blue", "cyan", "magenta", "orange", "grey")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1903
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1904 n.entry <- length(ez.list)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1905 x <- rep(NA, n.entry)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1906 y.max <- rep(NA, n.entry)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1907
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1908 for(i in 1:n.entry){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1909 x[i] <- max(ez.list[[i]]$n)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1910
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1911 y.max[i] <- max(ez.list[[i]]$IDR)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1912
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1913 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1914
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1915 if(is.null(y.lim))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1916 y.lim <- c(0, max(y.max))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1917
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1918 if(!is.null(file.name)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1919 postscript(paste(plot.dir, "ez.", file.name, sep=""))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1920 par(mfrow=c(1,1), mar=c(5,5,4,2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1921 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1922
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1923
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1924
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1925 plot(c(0, max(x)), y.lim, ylim=y.lim, type="n", xlab=xlab.txt, ylab=ylab.txt, lwd=5, cex=5, cex.axis=2, cex.lab=2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1926
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1927 q <- seq(0.01, 0.99, by=0.01)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1928
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1929 for(i in 1:length(ez.list)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1930
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1931 n.plot <- round(quantile(ez.list[[i]]$n, prob=q))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1932 IDR.plot <- ez.list[[i]]$IDR[n.plot]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1933 lines(n.plot, IDR.plot, col=col.txt[i], cex=2, lwd=5)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1934 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1935
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1936
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1937 legend(0, y.lim[2], legend=legend.txt, col=col.txt[1:length(col.txt)], lty=1, lwd=5, cex=2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1938
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1939 if(!is.null(title))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1940 title(title.txt)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1941
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1942 if(!is.null(file.name)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1943 dev.off()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1944 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1945
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1946 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1947
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1948
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1949
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1950 #############################################################################
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1951 #############################################################################
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1952 # statistics about peaks selected on the individual replicates
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1953 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1954 # idr.level: the consistency cutoff, say 0.05
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1955 # uri.output: a list of uri.output from consistency analysis generated by batch-consistency-analysis.r
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1956 # ez.list : a list of IDRs computed from get.ez.tt using the same idr.level
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1957 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1958 ##################
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1959
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1960
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1961 # obsolete?
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1962 # compute the error rate
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1963 # u.t and v.t are the quantiles
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1964 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1965 # map back to all peaks and report the number of peaks selected
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1966 get.ez.tt.all.old <- function(em.fit, all.data1, all.data2, idr.level){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1967
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1968 u <- em.fit$data.pruned$sample1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1969 v <- em.fit$data.pruned$sample2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1970
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1971 tt <- seq(0.01, 0.99, by=0.01)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1972 # if(reverse){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1973 e.z <- 1-em.fit$em.fit$e.z # this is the error prob
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1974 uri.ez <- sapply(tt, comp.uri.ez, u=u, v=v, e.z=e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1975 ez.bound <- sapply(tt, comp.ez.cutoff, u=u, v=v, e.z=e.z, boundary.txt="max")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1976 # } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1977 # e.z <- em.fit$em.fit$e.z
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1978 # uri.ez <- sapply(tt, comp.uri.ez, u=u, v=v, e.z=e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1979 # ez.bound <- sapply(tt, comp.ez.cutoff, u=u, v=v, e.z=e.z, boundary.txt="min")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1980 # }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1981
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1982 u.t <- quantile(u, prob=(1-tt))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1983 v.t <- quantile(v, prob=(1-tt))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1984
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1985 # find the levels on the two replicates
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1986 sig.value1 <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1987 sig.value2 <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1988 error.prob.cutoff <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1989 n.selected.match <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1990 npeak.rep1 <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1991 npeak.rep2 <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1992
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1993 for(i in 1:length(idr.level)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1994
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1995 # find which uri.ez is closet to idr.level
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1996 index <- which.min(abs(uri.ez - as.numeric(idr.level[i])))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1997
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1998 sig.value1[i] <- u.t[index]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
1999 sig.value2[i] <- v.t[index]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2000 error.prob.cutoff[i] <- ez.bound[index]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2001 n.selected.match[i] <- sum(u>= u.t[index] & v>=v.t[index])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2002
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2003 npeak.rep1[i] <- sum(all.data1["sig.value"] >= sig.value1[i])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2004 npeak.rep2[i] <- sum(all.data2["sig.value"] >= sig.value2[i])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2005 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2006
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2007
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2008 # output the cutoff of posterior probability, signal values on two replicates
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2009 map.uv <- cbind(error.prob.cutoff, sig.value1, sig.value2, n.selected.match, npeak.rep1, npeak.rep2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2010
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2011 return(list(n=tt*length(u), uri.ez=uri.ez, u.t=u.t, v.t=v.t, tt=tt, idr.level=idr.level, map.uv=map.uv, e.z=e.z, error.prob.cutoff=error.prob.cutoff))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2012 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2013
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2014
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2015 get.ez.tt.all <- function(em.fit, all.data1, all.data2, idr.level=c(0.01, 0.05, 0.1)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2016
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2017 u <- em.fit$data.pruned$sample1$sig.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2018 v <- em.fit$data.pruned$sample2$sig.value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2019 # u <- em.fit$data.pruned$sample1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2020 # v <- em.fit$data.pruned$sample2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2021
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2022 e.z <- 1-em.fit$em.fit$e.z # this is the error prob
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2023
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2024 o <- order(e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2025 e.z.ordered <- e.z[o]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2026 n.select <- c(1:length(e.z))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2027 IDR <- cumsum(e.z.ordered)/n.select
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2028
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2029 u.o <- u[o]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2030 v.o <- v[o]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2031
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2032 n.level <- length(idr.level)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2033 # sig.value1 <- rep(NA, n.level)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2034 # sig.value2 <- rep(NA, n.level)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2035 ez.cutoff <- rep(NA, n.level)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2036 n.selected <- rep(NA, n.level)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2037 npeak.rep1 <- rep(NA, n.level)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2038 npeak.rep2 <- rep(NA, n.level)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2039
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2040 for(i in 1:length(idr.level)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2041
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2042 # find which uri.ez is closet to fdr.level
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2043 index <- which.min(abs(IDR - idr.level[i]))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2044 # sig.value1[i] <- min(u.o[1:index])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2045 # sig.value2[i] <- min(v.o[1:index])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2046 ez.cutoff[i] <- e.z.ordered[index] # fixed on 02/20/10
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2047 n.selected[i] <- sum(e.z<=ez.cutoff[i])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2048 # npeak.rep1[i] <- sum(all.data1["sig.value"] >= sig.value1[i])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2049 # npeak.rep2[i] <- sum(all.data2["sig.value"] >= sig.value2[i])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2050 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2051
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2052 # output the cutoff of posterior probability, number of selected overlapped peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2053 map.uv <- cbind(ez.cutoff, n.selected)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2054
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2055 return(list(n=n.select, IDR=IDR, idr.level=idr.level, map.uv=map.uv))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2056 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2057
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2058 # return(list(n=tt*length(u), uri.ez=uri.ez, fdr.level=fdr.level, map.uv=map.uv, e.z=e.z, error.prob.cutoff=error.prob.cutoff))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2059
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2060
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2061
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2062
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2063
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2064
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2065 ####### the following is for determining thresholds for merged dataset
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2066
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2067 ############# select peaks above a given threshold
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2068 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2069 # pass.threshold: a simple method, passing the threshold on the threshold on the individual replicate to the pooled sample
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2070 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2071 # sig.map.list: a list of matrix to include all the cutoff values, each row corresponds to a cutoff. The first column is idr.level
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2072 # the 2nd column is the cutoff of ez, the rest of columns are consistency analysis for other replicates
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2073 # sig.value.name: the name of the sig.value column
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2074 # combined: combined dataset
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2075 # nrep: number of pairs of comparisons
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2076 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2077 # Procedure:
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2078 # 1. Find the significant threshold corresponding to the idr cutoff on the matched peaks.
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2079 # 2. Each time we will get two or more (if >2 replicates) cutoffs and will report the most stringent and the least stringent
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2080 # cutoff and the number of peaks selected at those two cutoffs
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2081 #############
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2082
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2083 pass.threshold <- function(sig.map.list, sig.value.name, combined, idr.level, nrep, chr.size){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2084
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2085 sig.map <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2086
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2087 # choose idr.level
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2088 idr.index <- which(rbind(sig.map.list[[1]])[,1] == idr.level)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2089 if(length(i) ==0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2090 print("no level matches specified idr.level")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2091 return(-1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2092 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2093
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2094 for(i in 1:length(sig.map.list))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2095 sig.map <- c(sig.map, rbind(sig.map.list[[i]])[idr.index, c("sig.value1", "sig.value2")])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2096
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2097
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2098 npeak.tight <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2099 npeak.loose <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2100
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2101
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2102 max.sig <- max(sig.map)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2103 min.sig <- min(sig.map)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2104 selected.sig.tight <- combined[combined[,sig.value.name]>=max.sig, ]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2105 selected.sig.loose <- combined[combined[,sig.value.name]>=min.sig, ]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2106
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2107 selected.sig.tight <- deconcatenate.chr(selected.sig.tight, chr.size)[,c("chr", "start", "stop", "signal.value", "p.value", "q.value")]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2108 selected.sig.loose <- deconcatenate.chr(selected.sig.loose, chr.size)[,c("chr", "start", "stop", "signal.value", "p.value", "q.value")]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2109
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2110 npeak.tight <- nrow(selected.sig.tight)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2111 npeak.loose <- nrow(selected.sig.loose)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2112
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2113
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2114 npeak.stat <- list(idr.level=idr.level, max.sig=max.sig, min.sig=min.sig, npeak.tight=npeak.tight, npeak.loose=npeak.loose)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2115
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2116 invisible(list(npeak.stat=npeak.stat, combined.selected.tight=selected.sig.tight, combined.selected.loose=selected.sig.loose))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2117 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2118
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2119 #################
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2120 # pass the regions selected from consistency analysis to combined data
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2121 # Threshold is determined on the replicates, the regions above the threshold are selected
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2122 # then peaks on the combined data are selected from the selected regions
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2123 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2124 # To avoid being too stringent, regions satisfying the following conditions are selected
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2125 # 1. regions above the significant threshold determined by consistency analysis on either replicate
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2126 # 2. regions that have consistent low peaks, i.e. posterior prob > threshold but not passing the significant threshold
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2127 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2128 # This method doesn't make a difference when using different thresholds
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2129 #################
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2130
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2131 pass.region <- function(sig.map.list, uri.output, ez.list, em.output, combined, idr.level, sig.value.impute=0, chr.size){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2132
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2133 combined <- combined[, c("start", "stop", "sig.value", "signal.value", "p.value", "q.value")]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2134 npair <- length(uri.output) # number of pairs of consistency analysis
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2135 combined.region <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2136
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2137 # choose idr.level
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2138 idr.index <- which(rbind(sig.map.list[[1]])[,1] == idr.level)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2139 if(length(idr.index) ==0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2140 print("no level matches specified idr.level")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2141 return(-1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2142 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2143
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2144 for(j in 1:npair){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2145 # select peaks from individual replicates using individual cutoff
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2146 above.1 <- uri.output[[j]]$data12.enrich$merge1["sig.value"] >= ez.list[[j]]$map.uv[idr.index,"sig.value1"]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2147 above.2 <- uri.output[[j]]$data12.enrich$merge1["sig.value"] >= ez.list[[j]]$map.uv[idr.index,"sig.value2"]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2148 selected.sig.rep1 <- uri.output[[j]]$data12.enrich$merge1[above.1, c("start", "stop", "sig.value", "signal.value", "p.value", "q.value")]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2149 selected.sig.rep2 <- uri.output[[j]]$data12.enrich$merge2[above.2, c("start", "stop", "sig.value", "signal.value", "p.value", "q.value")]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2150
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2151 # find the peaks that are overlapped with reliable peaks in the individual replicates
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2152 overlap.1 <- pair.peaks(selected.sig.rep1, combined)$merge2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2153 overlap.2 <- pair.peaks(selected.sig.rep2, combined)$merge2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2154
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2155 # choose the ones with significant value > 0, which are the overlapped ones
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2156
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2157 combined.in1 <- overlap.1[overlap.1$sig.value > sig.value.impute, c("start", "stop", "sig.value", "signal.value", "p.value", "q.value")]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2158 combined.in2 <- overlap.2[overlap.2$sig.value > sig.value.impute, c("start", "stop", "sig.value", "signal.value", "p.value", "q.value")]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2159
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2160 ## consistent low significant ones
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2161 ## first find consistenct ones, ie. high posterior prob
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2162 # is.consistent <- ez.list[[j]]$e.z < ez.list[[j]]$ez.cutoff
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2163
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2164 # data.matched <- keep.match(uri.output[[j]]$data12.enrich$merge1[!above.1, ], uri.output[[j]]$data12.enrich$merge2[!above.2, ], sig.value.impute=0)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2165 # data.matched$sample1 <- data.matched$sample1[, c("start", "stop", "sig.value", "signal.value", "p.value", "q.value")]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2166 # data.matched$sample2 <- data.matched$sample2[, c("start", "stop", "sig.value", "signal.value", "p.value", "q.value")]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2167
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2168 # consistent.in1 <- data.matched$sample1[is.consistent, ]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2169 # consistent.in2 <- data.matched$sample2[is.consistent, ]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2170
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2171 # overlap.consistent.1 <- pair.peaks(consistent.in1, combined)$merge2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2172 # overlap.consistent.2 <- pair.peaks(consistent.in2, combined)$merge2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2173
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2174 ## choose the ones with significant value > 0, which are the overlapped ones
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2175
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2176 # combined.consistent.in1 <- overlap.consistent.1[overlap.consistent.1$sig.value > sig.value.impute, ]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2177 # combined.consistent.in2 <- overlap.consistent.2[overlap.consistent.2$sig.value > sig.value.impute, ]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2178
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2179 # combined.region <- rbind(combined.region, combined.in1, combined.in2, combined.consistent.in1, combined.consistent.in2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2180
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2181 combined.region <- rbind(combined.region, combined.in1, combined.in2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2182
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2183 is.repeated <- duplicated(combined.region$start)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2184 combined.region <- combined.region[!is.repeated, c("start", "stop", "sig.value", "signal.value", "p.value", "q.value")]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2185
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2186 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2187 npeak <- nrow(combined.region)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2188
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2189 sig.combined <- c(min(combined.region[,"sig.value"], na.rm=T), max(combined.region[,"sig.value"], na.rm=T))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2190
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2191 # idr.combined <- c(min(combined.region[,"q.value"], na.rm=T), max(combined.region[,"q.value"], na.rm=T))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2192
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2193 npeak.stat <- list(idr.level=idr.level, npeak=npeak)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2194
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2195 combined.region <- deconcatenate.chr(combined.region, chr.size)[,c("chr", "start", "stop", "signal.value", "p.value", "q.value")]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2196
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2197 invisible(list(npeak.stat=npeak.stat, combined.selected=combined.region, sig.combined=sig.combined))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2198 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2199
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2200 ################
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2201 # pass structure: this method does another round of inference on the combined data
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2202 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2203 # To make the mixture structure comparable on the replicates and the combined data, the 2nd inference is done on the peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2204 # at the reliable regions on the combined data, using rank transformed significant values. The mixture structure is estimated using my consistency analysis, which
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2205 # estimates marginal distributions of ranks using nonparametric ways. Then the significant values are found out.
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2206 # There are several advantages to do it this way:
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2207 # 1. The premise of passing structure is that the means and variance (i.e. distribution) of two replicates should be the same
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2208 # The significant values on the two replicates clearly have different distributions. The structure estimated from consistency
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2209 # analysis will generate similar rank distribution on two replicates by its setup (i.e. same number of peaks are paired up).
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2210 # 2. Because pooled sample is a black box, the structure is more likely to be followed in the matched regions than other locations,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2211 # after all, we don't know what other things are. If even the structure doesn't hold on the matched regions,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2212 # which is possible, let alone the other regions. Focusing on the reliable regions helps to get rid of those unknown noises.
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2213 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2214 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2215 # modified on 2-20-10: reverse rank.combined, make big sig.value with small
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2216 # ranks, to be consistent with f1 and f2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2217 ################
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2218
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2219 pass.structure <- function(uri.output, em.output, combined, idr.level, sig.value.impute, chr.size, overlap.ratio=0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2220
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2221 columns.keep <- c("sig.value", "start", "stop", "signal.value", "p.value", "q.value", "chr", "start.ori", "stop.ori")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2222 combined <- combined[, columns.keep]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2223 combined.selected.all <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2224
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2225 for(j in 1:npair){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2226
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2227 sample1 <- uri.output[[j]]$data12.enrich$merge1[, columns.keep]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2228 sample2 <- uri.output[[j]]$data12.enrich$merge2[, columns.keep]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2229
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2230 # find peaks on the matched region on the combined one
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2231 data.matched <- keep.match(sample1, sample2, sig.value.impute=sig.value.impute)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2232
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2233 data.matched$sample1 <- data.matched$sample1[, columns.keep]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2234 data.matched$sample2 <- data.matched$sample2[, columns.keep]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2235
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2236 overlap.1 <- pair.peaks.filter(data.matched$sample1, combined, p.value.impute=sig.value.impute, overlap.ratio)$merge2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2237 overlap.2 <- pair.peaks.filter(data.matched$sample2, combined, p.value.impute=sig.value.impute, overlap.ratio)$merge2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2238
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2239 # choose the ones with significant value > sig.value.impute, which are the overlapped ones
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2240
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2241 combined.in1 <- overlap.1[overlap.1$sig.value > sig.value.impute, ]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2242 combined.in2 <- overlap.2[overlap.2$sig.value > sig.value.impute, ]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2243
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2244 combined.region <- rbind(combined.in1, combined.in2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2245
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2246 is.repeated <- duplicated(combined.region$start)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2247 combined.region <- combined.region[!is.repeated,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2248
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2249 # now rank the peaks in matched region
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2250 rank.combined <- rank(-combined.region$sig.value)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2251
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2252 # now transform the parameters estimated into the new scale
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2253 npeaks.overlap <- nrow(combined.region)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2254 npeaks.consistent <- nrow(cbind(em.output[[j]]$data.pruned$sample1))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2255
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2256
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2257 # the breaks are the same for x and y
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2258 f1 <- list(breaks=em.output[[j]]$em.fit$x.mar$f1$breaks*npeaks.overlap/npeaks.consistent, density=(em.output[[j]]$em.fit$x.mar$f1$density+em.output[[j]]$em.fit$y.mar$f1$density)/2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2259 # the first break boundary goes up when changing scale, need set it back to be a bit smaller than 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2260 f1$breaks[1] <- min(f1$breaks[1], 0.95)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2261
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2262 f2 <- list(breaks=em.output[[j]]$em.fit$x.mar$f2$breaks*npeaks.overlap/npeaks.consistent, density=(em.output[[j]]$em.fit$x.mar$f2$density+em.output[[j]]$em.fit$y.mar$f2$density)/2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2263 # the first break boundary goes up when changing scale, need set it back to be a bit smaller than 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2264 f2$breaks[1] <- min(f2$breaks[1], 0.95)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2265
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2266 p <- em.output[[j]]$em.fit$para$p
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2267
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2268 # find the posterior probability
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2269 errorprob.combined <- get.comp2.prob(rank.combined, p, f1, f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2270
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2271 # compute the FDR and find cutoff of posterior prob and the sig value
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2272 o <- order(errorprob.combined)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2273 idr <- cumsum(errorprob.combined[o])/c(1:length(o))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2274 idr.index <- which(idr > idr.level)[1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2275 errorprob.cutoff <- errorprob.combined[o][idr.index]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2276
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2277 # find the minimum significant measure among selected peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2278 sig.value <- min(combined.region$sig.value[o][1:idr.index])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2279 # sig.value <- quantile(combined.region$sig.value[o][1:idr.index], prob=0.05)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2280 #sig.value <- quantile(combined.region$sig.value[errorprob.combined<=errorprob.cutoff], prob=0.05)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2281
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2282 # apply the significant value on the whole pooled list
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2283 combined.selected <- combined[combined$sig.value >= sig.value,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2284
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2285 combined.selected.all <- rbind(combined.selected.all, combined.selected)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2286 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2287
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2288 is.repeated <- duplicated(combined.selected.all$start)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2289 combined.selected.all <- combined.selected.all[!is.repeated,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2290
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2291 npeak <- nrow(combined.selected.all)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2292
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2293 npeak.stat <- list(idr.level=idr.level, npeak=npeak)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2294
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2295 sig.combined <- c(min(combined.selected.all[,"sig.value"], na.rm=T), max(combined.selected.all[,"sig.value"], na.rm=T))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2296
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2297 # idr.combined <- c(min(combined.selected.all[,"q.value"], na.rm=T), max(combined.selected.all[,"q.value"], na.rm=T))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2298 # combined.selected.all <- deconcatenate.chr(combined.selected.all, chr.size)[,c("chr", "start", "stop", "signal.value", "p.value", "q.value")]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2299
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2300 combined.selected.all <- combined.selected.all[, c("chr", "start.ori", "stop.ori", "signal.value", "p.value", "q.value")]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2301 colnames(combined.selected.all) <- c("chr", "start", "stop", "signal.value", "p.value", "q.value")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2302
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2303 invisible(list(npeak.stat=npeak.stat, combined.selected=combined.selected.all, sig.combined=sig.combined))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2304 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2305
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2306
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2307
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2308 # get the posterior probability of the 2nd component
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2309 get.comp2.prob <- function(x, p, f1, f2){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2310
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2311 # get pdf and cdf of each component from functions in the corresponding component
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2312 px.1 <- sapply(x, get.pdf, df=f1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2313 px.2 <- sapply(x, get.pdf, df=f2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2314
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2315 comp2prob <- 1 - p*px.1/(p*px.1+(1-p)*px.2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2316
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2317 return(comp2prob)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2318 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2319
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2320 keep.match <- function(sample1, sample2, sig.value.impute=0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2321
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2322 sample1.prune <- sample1[sample1$sig.value > sig.value.impute & sample2$sig.value > sig.value.impute,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2323 sample2.prune <- sample2[sample1$sig.value > sig.value.impute & sample2$sig.value > sig.value.impute,]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2324
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2325 invisible(list(sample1=sample1.prune, sample2=sample2.prune))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2326 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2327
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2328
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2329 ##############################################
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2330 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2331 # The following is for simulation
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2332 #
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2333 ##############################################
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2334
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2335
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2336 # simulate gaussian copula
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2337 # u is the uniform random variable and rho is correlation coefficient
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2338 simu.gaussian.copula <- function(u, rho){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2339
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2340 n <- length(u)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2341
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2342 # simulate y given x=qnorm(u)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2343 y <- qnorm(u)*rho + rnorm(n)*sqrt(1-rho^2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2344
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2345 v <- pnorm(y)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2346
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2347 invisible(v)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2348 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2349
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2350 ## simulate Clayton copula from its generating function
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2351 ## Genest and MacKay (1986)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2352
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2353 phi.ori <- function(t, s){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2354
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2355 (t^(-s) -1)/s
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2356 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2357
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2358
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2359 phi.inv <- function(y, s){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2360
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2361 exp(-log(s*y+1)/s)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2362 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2363
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2364 phi.der <- function(t, s){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2365
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2366 -t^(-s-1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2367 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2368
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2369 phi.der.inv <- function(y, s){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2370
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2371 exp(log(-y)/(-s-1))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2372 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2373
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2374 get.w <- function(u, t, s){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2375
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2376 phi.der.inv(phi.der(u, s)/t, s)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2377 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2378
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2379 get.v <- function(w, u, s){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2380
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2381 phi.inv(phi.ori(w, s) - phi.ori(u, s), s)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2382 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2383
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2384 # u is a uniform random variable, s is the association parameter
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2385 simu.clayton.copula <- function(u, s){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2386
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2387 t <- runif(length(u))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2388
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2389 if(s>0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2390 w <- get.w(u, t, s)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2391 v <- get.v(w, u, s)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2392 return(v)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2393 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2394
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2395 if(s==0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2396 return(t)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2397 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2398
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2399 if(s <0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2400 print("Invalid association parameters for clayton copula")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2401 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2402
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2403 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2404
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2405
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2406
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2407 ###### 09-09-09
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2408
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2409 # simulate a two-component copula mixture:
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2410 # - marginal distributions for the two variables in each component are both
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2411 # normal and with the same parameters
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2412 # p is the mixing proportion of component 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2413 # n is the total sample size
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2414 simu.copula.2mix <- function(s1, s2, p, n, mu1, mu2, sd1, sd2, copula.txt){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2415
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2416 n1 <- round(n*p)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2417 n2 <- n-n1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2418
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2419 u1 <- runif(n1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2420
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2421 if(copula.txt =="clayton")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2422 v1 <- simu.clayton.copula(u1, s1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2423 else{
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2424 if(copula.txt =="gaussian")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2425 v1 <- simu.gaussian.copula(u1, s1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2426 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2427
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2428 u2 <- runif(n2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2429
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2430 if(copula.txt =="clayton")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2431 v2 <- simu.clayton.copula(u2, s2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2432 else{
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2433 if(copula.txt =="gaussian")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2434 v2 <- simu.gaussian.copula(u2, s2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2435 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2436
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2437 # generate test statistics
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2438 sample1.1 <- qnorm(u1, mu1, sd1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2439 sample1.2 <- qnorm(v1, mu1, sd1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2440
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2441 sample2.1 <- qnorm(u2, mu2, sd2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2442 sample2.2 <- qnorm(v2, mu2, sd2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2443
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2444 return(list(u=c(u1, u2), v=c(v1, v2),
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2445 u.inv=c(sample1.1, sample2.1), v.inv=c(sample1.2, sample2.2),
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2446 label=c(rep(1, n1), rep(2, n2))))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2447 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2448
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2449 # using inverse of the cdf to generate original observations
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2450
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2451 simu.copula.2mix.inv <- function(s1, s2, p, n, cdf1.x, cdf1.y, cdf2.x, cdf2.y, copula.txt){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2452
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2453 n1 <- round(n*p)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2454 n2 <- n-n1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2455
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2456 u1 <- runif(n1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2457
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2458 if(copula.txt =="clayton")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2459 v1 <- simu.clayton.copula(u1, s1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2460 else{
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2461 if(copula.txt =="gaussian")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2462 v1 <- simu.gaussian.copula(u1, s1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2463 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2464
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2465 u2 <- runif(n2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2466
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2467 if(copula.txt =="clayton")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2468 v2 <- simu.clayton.copula(u2, s2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2469 else{
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2470 if(copula.txt =="gaussian")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2471 v2 <- simu.gaussian.copula(u2, s2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2472 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2473
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2474 # generate test statistics
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2475 # sample1.1 <- qnorm(u1, mu1, sd1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2476 # sample1.2 <- qnorm(v1, mu1, sd1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2477
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2478 # sample2.1 <- qnorm(u2, mu2, sd2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2479 # sample2.2 <- qnorm(v2, mu2, sd2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2480
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2481 sample1.x <- inv.cdf.vec(u1, cdf1.x)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2482 sample1.y <- inv.cdf.vec(v1, cdf1.y)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2483
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2484 sample2.x <- inv.cdf.vec(u2, cdf2.x)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2485 sample2.y <- inv.cdf.vec(v2, cdf2.y)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2486
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2487
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2488 return(list(u=c(u1, u2), v=c(v1, v2),
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2489 u.inv=c(sample1.x, sample2.x), v.inv=c(sample1.y, sample2.y),
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2490 label=c(rep(1, n1), rep(2, n2))))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2491 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2492
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2493 # obtain original observation by converting cdf into quantiles
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2494 # u is one cdf
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2495 # u.cdf is a cdf (assuming it is a histogram) and has the break points (cdf$cdf and cdf$breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2496 # the smallest value of cdf=0 and the largest =1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2497 inv.cdf <- function(u, u.cdf){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2498
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2499 # which bin it falls into
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2500 i <- which(u.cdf$cdf> u)[1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2501 q.u <- (u - u.cdf$cdf[i-1])/(u.cdf$cdf[i] - u.cdf$cdf[i-1])* (u.cdf$breaks[i]-u.cdf$breaks[i-1]) + u.cdf$breaks[i-1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2502
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2503 return(q.u)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2504 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2505
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2506 inv.cdf.vec <- function(u, u.cdf){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2507
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2508 # check if cdf has the right range (0, 1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2509 ncdf <- length(u.cdf$cdf)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2510 nbreaks <- length(u.cdf$breaks)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2511
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2512 if(ncdf == nbreaks-1 & u.cdf$cdf[ncdf]< 1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2513 u.cdf[ncdf] <- 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2514
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2515 q.u <- sapply(u, inv.cdf, u.cdf)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2516
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2517 return(q.u)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2518 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2519
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2520 # here we simulate a likely real situation
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2521 # the test statistics from two normal distributions
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2522 # according to their labels, then convert them into p-values w.r.t H0 using
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2523 # one-sided test.
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2524 # The test statistics are correlated for the signal component and independent
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2525 # for the noise component
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2526 # For the signal component, Y = X + eps, where eps ~ N(0, sigma^2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2527 simu.test.stat <- function(p, n, mu1, sd1, mu0, sd0, sd.e){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2528
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2529 # first component - signal
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2530 n.signal <- round(n*p)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2531 n.noise <- n - n.signal
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2532
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2533 # labels
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2534 labels <- c(rep(1, n.signal), rep(0, n.noise))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2535
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2536 # test statistics for signal and noise
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2537 mu.signal <- rnorm(n.signal, mu1, sd1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2538 x.signal <- mu.signal + rnorm(n.signal, 0, sd.e)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2539 x.noise <- rnorm(n.noise, mu0, sd0) + rnorm(n.noise, 0, sd.e)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2540
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2541 y.signal <- mu.signal + rnorm(n.signal, 0, sd.e)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2542 # sd.e can be dependent on signal
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2543 y.noise <- rnorm(n.noise, mu0, sd0) + rnorm(n.noise, 0, sd.e)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2544
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2545 # concatenate
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2546 x <- c(x.signal, x.noise)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2547 y <- c(y.signal, y.noise)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2548
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2549 # convert to p-values based on H0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2550 p.x <- 1-pnorm(x, mu0, sqrt(sd0^2+sd.e^2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2551 p.y <- 1-pnorm(y, mu0, sqrt(sd0^2+sd.e^2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2552
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2553 return(list(p.x=p.x, p.y=p.y, x=x, y=y, labels=labels))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2554
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2555 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2556
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2557 # compute the tradeoff and calibration
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2558 forward.decoy.tradeoff.ndecoy <- function(xx, labels, ndecoy){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2559
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2560 xx <- round(xx, 5)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2561 o <- order(xx, decreasing=T)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2562
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2563 rand <- 1-labels # if rand==0, consistent
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2564 # order the random indicator in the same order
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2565 rand.o <- rand[o]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2566
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2567 if(sum(rand.o) > ndecoy){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2568 index.decoy <- which(cumsum(rand.o)==ndecoy)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2569 } else {
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2570 index.decoy <- which(cumsum(rand.o)==sum(rand.o))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2571 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2572
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2573 cutoff.decoy <- xx[o][index.decoy]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2574
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2575 # only consider the unique ones
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2576 cutoff.unique <- unique(xx[o])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2577
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2578 cutoff <- cutoff.unique[cutoff.unique >= cutoff.decoy[length(cutoff.decoy)]]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2579
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2580 get.decoy.count <- function(cut.off){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2581 above <- rep(0, length(xx))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2582 above[xx >= cut.off] <- 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2583 decoy.count <- sum(above==1 & rand==1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2584 return(decoy.count)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2585 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2586
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2587 get.forward.count <- function(cut.off){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2588 above <- rep(0, length(xx))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2589 above[xx >= cut.off] <- 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2590 forward.count <- sum(above==1 & rand==0)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2591 return(forward.count)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2592 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2593
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2594 get.est.fdr <- function(cut.off){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2595 above <- rep(0, length(xx))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2596 above[xx >= cut.off] <- 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2597 est.fdr <- 1-mean(xx[above==1])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2598 return(est.fdr)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2599 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2600
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2601 # assuming rand=0 is right
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2602 get.false.neg.count <- function(cut.off){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2603 below <- rep(0, length(xx))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2604 below[xx < cut.off] <- 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2605 false.neg.count <- sum(below==1 & rand==0)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2606 return(false.neg.count)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2607 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2608
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2609 get.false.pos.count <- function(cut.off){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2610 above <- rep(0, length(xx))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2611 above[xx >= cut.off] <- 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2612 false.pos.count <- sum(above==1 & rand==1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2613 return(false.pos.count)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2614 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2615
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2616 decoy <- sapply(cutoff, get.decoy.count)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2617 forward <- sapply(cutoff, get.forward.count)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2618
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2619 est.fdr <- sapply(cutoff, get.est.fdr)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2620 emp.fdr <- decoy/(decoy+forward)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2621
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2622 # compute specificity and sensitivity
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2623 # assuming rand=1 is wrong and rand=0 is right
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2624 false.neg <- sapply(cutoff, get.false.neg.count)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2625 false.pos <- sapply(cutoff, get.false.pos.count)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2626
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2627 true.pos <- sum(rand==0)-false.neg
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2628 true.neg <- sum(rand==1)-false.pos
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2629
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2630 sensitivity <- true.pos/(true.pos+false.neg)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2631 specificity <- true.neg/(true.neg+false.pos)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2632
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2633 return(list(decoy=decoy, forward=forward, cutoff=cutoff, est.fdr=est.fdr, emp.fdr=emp.fdr, sensitivity=sensitivity, specificity=specificity))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2634 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2635
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2636
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2637 # compute the em for jackknife and all data, and find FDR
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2638 get.emp.jack <- function(a, p0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2639
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2640 nobs <- length(a$labels)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2641 est <- list()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2642 est.all <- list()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2643
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2644 temp.all <- em.transform(-a$p.x, -a$p.y, mu=1.5, sigma=1.4, rho=0.4, p=0.7, eps=0.01)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2645 # temp.all <- em.2copula.quick(a$p.x, a$p.y, p0=p0, rho1.0=0.7,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2646 # rho2.0=0, eps=0.01, fix.p=T, stoc=F, fix.rho2=T, "gaussian")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2647
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2648 est.all$p <- temp.all$para$p
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2649 est.all$rho1 <- temp.all$para$rho1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2650 est.all$FDR <- get.FDR(temp.all$e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2651
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2652 FDR <- list()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2653 p <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2654 rho1 <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2655
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2656
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2657 for(i in 1:nobs){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2658
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2659 temp <- em.transform(-a$p.x[-i], -a$p.y[-i], mu=1.5, sigma=1.4, rho=0.4, p=0.7, eps=0.01)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2660 # temp <- em.2copula.quick(a$p.x[-i], a$p.y[-i], p0=p0, rho1.0=0.7,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2661 # rho2.0=0, eps=0.01, fix.p=T, stoc=F, fix.rho2=T, "gaussian")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2662
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2663 est[[i]] <- list(p=temp$para$p, rho1=temp$para$rho1, FDR=get.FDR(temp$e.z))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2664
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2665 FDR[[i]] <- est[[i]]$FDR # this is the FDR for top n peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2666 p[i] <- est[[i]]$p
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2667 rho1[i] <- est[[i]]$rho1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2668 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2669
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2670 est.jack <- list(FDR=FDR, p=p, rho1=rho1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2671 return(list(est.jack=est.jack, est.all=est.all))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2672 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2673
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2674
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2675 # get the npeaks corresponding to the nominal FDR estimated from the sample
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2676 # and find the corresponding FDR from the entire data
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2677 get.FDR.jack <- function(est, FDR.nominal){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2678
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2679 nobs <- length(est$est.jack$FDR)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2680 FDR.all <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2681 top.n <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2682
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2683 for(i in 1:nobs){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2684 top.n[i] <- max(which(est$est.jack$FDR[[i]] <= FDR.nominal))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2685 FDR.all[i] <- est$est.all$FDR[top.n[i]]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2686 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2687
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2688 invisible(list(FDR.all=FDR.all, top.n=top.n))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2689 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2690
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2691 # compute Jackknife peudonumber
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2692 # a is the dataset
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2693 get.emp.IF <- function(a, p0){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2694
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2695 nobs <- length(a$labels)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2696 est <- list()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2697 est.all <- list()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2698
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2699 temp.all <- em.2copula.quick(a$p.x, a$p.y, p0=p0, rho1.0=0.7,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2700 rho2.0=0, eps=0.01, fix.p=T, stoc=F, fix.rho2=T, "gaussian")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2701
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2702 est.all$p <- temp.all$para$p
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2703 est.all$rho1 <- temp.all$para$rho1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2704 est.all$FDR <- get.FDR(temp.all$e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2705
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2706 IF.FDR <- list()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2707 IF.p <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2708 IF.rho1 <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2709
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2710 for(i in 1:nobs){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2711
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2712 temp <- em.2copula.quick(a$p.x[-i], a$p.y[-i], p0=p0, rho1.0=0.7,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2713 rho2.0=0, eps=0.01, fix.p=T, stoc=F, fix.rho2=T, "gaussian")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2714
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2715 est[[i]] <- list(p=temp$para$p, rho1=temp$para$rho1, FDR=get.FDR(temp$e.z))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2716
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2717 IF.FDR[[i]] <- (nobs-1)*(est.all$FDR[-nobs] - est[[i]]$FDR) # this is the FDR for top n peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2718 IF.p[i] <- (nobs-1)*(est.all$p - est[[i]]$p)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2719 IF.rho1[i] <- (nobs-1)*(est.all$rho1 - est[[i]]$rho1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2720 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2721
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2722 emp.IF <- list(FDR=IF.FDR, p=IF.p, rho1=IF.rho1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2723
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2724 invisible(list(emp.IF=emp.IF, est.all=est.all, est=est))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2725 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2726
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2727 # e.z is the posterior probability of being in signal component
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2728 get.FDR <- function(e.z){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2729
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2730 e.z.o <- order(1-e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2731 FDR <- cumsum(1-e.z[e.z.o])/c(1:length(e.z.o))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2732
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2733 invisible(FDR)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2734 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2735
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2736 # get the FDR of selecting the top n peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2737 # IF.est is the sample influence function
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2738 # top.n
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2739 get.IF.FDR <- function(IF.est, top.n){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2740
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2741 nobs <- length(IF.est$emp.IF$FDR)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2742 FDR <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2743
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2744 # influence function of p
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2745 for(i in 1:nobs)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2746 FDR[i] <- IF.est$emp.IF$FDR[[i]][top.n]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2747
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2748 invisible(FDR)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2749 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2750
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2751 # get the sample influence function for FDR at a given FDR size
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2752 # 1. find the number of peaks selected at a given FDR computed from all obs
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2753 # 2. use the number to find the sample influence function for FDR
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2754 # IF.est$est.all is the FDR with all peaks
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2755 get.IF.FDR.all <- function(IF.est, FDR.size){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2756
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2757 top.n <- which.min(abs(IF.est$est.all$FDR -FDR.size))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2758 nobs <- length(IF.est$est.all$FDR)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2759 FDR <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2760
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2761 # influence function of p
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2762 for(i in 1:nobs)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2763 FDR[i] <- IF.est$emp.IF$FDR[[i]][top.n]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2764
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2765 invisible(list(FDR=FDR, top.n=top.n))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2766 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2767
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2768 plot.simu.uri <- function(x, y){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2769
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2770 tt <- seq(0.01, 0.99, by=0.01)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2771 uri <- sapply(tt, comp.uri.prob, u=x, v=y)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2772 uri.thin <- uri[seq(1, length(tt), by=3)]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2773 tt.thin <- tt[seq(1, length(tt), by=3)]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2774 duri <- (uri.thin[-1]-uri.thin[-length(uri.thin)])/(tt.thin[-1]-tt.thin[-length(tt.thin)])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2775 uri.spl <- smooth.spline(tt, uri, df=6.4)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2776 uri.der <- predict(uri.spl, tt, deriv=1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2777
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2778 par(mfrow=c(2,2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2779 plot(x[1:n0], y[1:n0])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2780 points(x[(n0+1):n], y[(n0+1):n], col=2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2781 plot(rank(-x)[1:n0], rank(-y)[1:n0])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2782 points(rank(-x)[(1+n0):n], rank(-y)[(1+n0):n])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2783 plot(tt, uri)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2784 lines(c(0,1), c(0,1), lty=2)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2785 title(paste("rho1=", rho1, " rho2=", rho2, "p=", p, sep=""))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2786 plot(tt.thin[-1], duri)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2787 lines(uri.der)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2788 abline(h=1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2789 invisible(list(x=x, y=y, uri=uri, tt=tt, duri=duri, tt.thin=tt.thin, uri.der=uri.der))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2790
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2791 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2792
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2793
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2794 ###### new fitting procedure
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2795
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2796
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2797
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2798
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2799 # 1. rank pairs
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2800
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2801 # 2. initialization
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2802 # 3. convert to pseudo-number
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2803
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2804 # 4. EM
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2805
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2806 # need plugin and test
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2807 # find the middle point between the bins
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2808 get.pseudo.mix <- function(x, mu, sigma, rho, p){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2809
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2810
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2811 # first compute cdf for points on the grid
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2812 # generate 200 points between [-3, mu+3*sigma]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2813 nw <- 1000
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2814 w <- seq(min(-3, mu-3*sigma), max(mu+3*sigma, 3), length=nw)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2815 w.cdf <- p*pnorm(w, mean=mu, sd=sigma) + (1-p)*pnorm(w, mean=0, sd=1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2816
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2817 i <- 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2818
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2819 quan.x <- rep(NA, length(x))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2820
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2821 for(i in c(1:nw)){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2822 index <- which(x >= w.cdf[i] & x < w.cdf[i+1])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2823 quan.x[index] <- (x[index]-w.cdf[i])*(w[i+1]-w[i])/(w.cdf[i+1]-w.cdf[i]) +w[i]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2824 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2825
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2826 index <- which(x < w.cdf[1])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2827 if(length(index)>0)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2828 quan.x[index] <- w[1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2829
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2830 index <- which(x > w.cdf[nw])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2831 if(length(index)>0)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2832 quan.x[index] <- w[nw]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2833
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2834 # linear.ext <- function(x, w, w.cdf){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2835 # linear interpolation
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2836 # index.up <- which(w.cdf>= x)[1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2837 # left.index <- which(w.cdf <=x)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2838 # index.down <- left.index[length(left.index)]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2839 # quan.x <- (w[index.up] + w[index.down])/2
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2840 # }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2841
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2842 # x.pseudo <- sapply(x, linear.ext, w=w, w.cdf=w.cdf)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2843
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2844 # invisible(x.pseudo)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2845 invisible(quan.x)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2846 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2847
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2848
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2849 # EM to compute the latent structure
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2850 # steps:
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2851 # 1. raw values are first transformed into pseudovalues
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2852 # 2. EM is used to compute the underlining structure, which is a mixture
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2853 # of two normals
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2854 em.transform <- function(x, y, mu, sigma, rho, p, eps){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2855
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2856 x.cdf.func <- ecdf(x)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2857 y.cdf.func <- ecdf(y)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2858 afactor <- length(x)/(length(x)+1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2859 x.cdf <- x.cdf.func(x)*afactor
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2860 y.cdf <- y.cdf.func(y)*afactor
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2861
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2862 # initialization
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2863 para <- list()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2864 para$mu <- mu
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2865 para$sigma <- sigma
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2866 para$rho <- rho
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2867 para$p <- p
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2868
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2869 j <- 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2870 to.run <- T
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2871 loglik.trace <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2872 loglik.inner.trace <- c()
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2873
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2874 #to.run.inner <- T
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2875 z.1 <- get.pseudo.mix(x.cdf, para$mu, para$sigma, para$rho, para$p)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2876 z.2 <- get.pseudo.mix(y.cdf, para$mu, para$sigma, para$rho, para$p)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2877
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2878 # cat("length(z1)", length(z.1), "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2879 while(to.run){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2880
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2881 # get pseudo value in each cycle
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2882 # z.1 <- get.pseudo.mix(x.cdf, para$mu, para$sigma, para$rho, para$p)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2883 # z.2 <- get.pseudo.mix(y.cdf, para$mu, para$sigma, para$rho, para$p)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2884
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2885 i <- 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2886 while(to.run){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2887
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2888 # EM for latent structure
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2889 e.z <- e.step.2normal(z.1, z.2, para$mu, para$sigma, para$rho, para$p)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2890 para <- m.step.2normal(z.1, z.2, e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2891 #para$rho <- rho
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2892 #para$p <- p
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2893 #para$mu <- mu
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2894 #para$sigma <- sigma
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2895 if(i > 1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2896 l.old <- l.new
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2897
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2898 # this is just the mixture likelihood of two-component Gaussian
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2899 l.new <- loglik.2binormal(z.1, z.2, para$mu, para$sigma, para$rho, para$p)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2900
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2901 loglik.inner.trace[i] <- l.new
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2902
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2903 if(i > 1){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2904 to.run <- loglik.inner.trace[i]-loglik.inner.trace[i-1]>eps
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2905 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2906
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2907
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2908 # if(i > 2){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2909 # l.inf <- loglik.inner.trace[i-2] + (loglik.inner.trace[i-1] - loglik.inner.trace[i-2])/(1-(loglik.inner.trace[i]-loglik.inner.trace[i-1])/(loglik.inner.trace[i-1]-loglik.inner.trace[i-2]))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2910
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2911 # if(loglik.inner.trace[i-1]!=loglik.inner.trace[i-2])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2912 # to.run <- abs(l.inf - loglik.inner.trace[i]) > eps
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2913 # else
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2914 # to.run <- F
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2915
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2916 # }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2917
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2918 cat("loglik.inner.trace[", i, "]=", loglik.inner.trace[i], "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2919 cat("mu=", para$mu, "sigma=", para$sigma, "p=", para$p, "rho=", para$rho, "\n\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2920
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2921 i <- i+1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2922 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2923
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2924
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2925 # get pseudo value in each cycle
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2926 z.1 <- get.pseudo.mix(x.cdf, para$mu, para$sigma, para$rho, para$p)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2927 z.2 <- get.pseudo.mix(y.cdf, para$mu, para$sigma, para$rho, para$p)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2928
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2929 if(j > 1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2930 l.old.outer <- l.new.outer
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2931
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2932 l.new.outer <- loglik.2binormal(z.1, z.2, para$mu, para$sigma, para$rho, para$p)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2933
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2934 loglik.trace[j] <- l.new.outer
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2935
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2936 if(j == 1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2937 to.run <- T
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2938 else{ # stop when iteration>100
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2939 if(j > 100)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2940 to.run <- F
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2941 else
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2942 to.run <- l.new.outer - l.old.outer > eps
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2943 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2944
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2945 # if(j %% 10==0)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2946 cat("loglik.trace[", j, "]=", loglik.trace[j], "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2947 cat("mu=", para$mu, "sigma=", para$sigma, "p=", para$p, "rho=", para$rho, "\n")
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2948
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2949 j <- j+1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2950 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2951
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2952 bic <- -2*l.new + 4*log(length(z.1))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2953
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2954 return(list(para=list(p=para$p, rho=para$rho, mu=para$mu, sigma=para$sigma),
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2955 loglik=l.new, bic=bic, e.z=e.z, loglik.trace=loglik.trace))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2956 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2957
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2958
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2959
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2960
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2961 # compute log-likelihood for mixture of two bivariate normals
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2962 loglik.2binormal <- function(z.1, z.2, mu, sigma, rho, p){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2963
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2964 l.m <- sum(d.binormal(z.1, z.2, 0, 1, 0)+log(p*exp(d.binormal(z.1, z.2, mu, sigma, rho)-d.binormal(z.1, z.2, 0, 1, 0))+(1-p)))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2965
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2966 # l.m <- sum((p*d.binormal(z.1, z.2, mu, sigma, rho) + (1-p)*d.binormal(z.1, z.2, 0, 1, 0)))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2967 return(l.m)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2968 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2969
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2970 # check this when rho=1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2971
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2972 # density of binomial distribution with equal mean and sigma on both dimensions
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2973 d.binormal <- function(z.1, z.2, mu, sigma, rho){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2974
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2975 loglik <- (-log(2)-log(pi)-2*log(sigma) - log(1-rho^2)/2 - (0.5/(1-rho^2)/sigma^2)*((z.1-mu)^2 -2*rho*(z.1-mu)*(z.2-mu) + (z.2-mu)^2))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2976
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2977 return(loglik)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2978 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2979
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2980 # E-step for computing the latent strucutre
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2981 # e.z is the prob to be in the consistent group
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2982 # e.step for estimating posterior prob
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2983 # z.1 and z.2 can be vectors or scalars
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2984 e.step.2normal <- function(z.1, z.2, mu, sigma, rho, p){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2985
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2986 e.z <- p/((1-p)*exp(d.binormal(z.1, z.2, 0, 1, 0)-d.binormal(z.1, z.2, mu, sigma, rho))+ p)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2987
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2988 invisible(e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2989 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2990
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2991 # M-step for computing the latent structure
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2992 # m.step for estimating proportion, mean, sd and correlation coefficient
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2993 m.step.2normal <- function(z.1, z.2, e.z){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2994
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2995 p <- mean(e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2996 mu <- sum((z.1+z.2)*e.z)/2/sum(e.z)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2997 sigma <- sqrt(sum(e.z*((z.1-mu)^2+(z.2-mu)^2))/2/sum(e.z))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2998 rho <- 2*sum(e.z*(z.1-mu)*(z.2-mu))/(sum(e.z*((z.1-mu)^2+(z.2-mu)^2)))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
2999
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3000 return(list(p=p, mu=mu, sigma=sigma, rho=rho))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3001 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3002
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3003
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3004 # assume top p percent of observations are true
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3005 # x and y are ranks, estimate
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3006 init <- function(x, y, x.label){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3007
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3008 x.o <- order(x)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3009
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3010 x.ordered <- x[x.o]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3011 y.ordered <- y[x.o]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3012 x.label.ordered <- x.label[x.o]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3013
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3014 n <- length(x)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3015 p <- sum(x.label)/n
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3016
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3017 rho <- cor(x.ordered[1:ceiling(p*n)], y.ordered[1:ceiling(p*n)])
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3018
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3019 temp <- find.mu.sigma(x.ordered, x.label.ordered)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3020 mu <- temp$mu
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3021 sigma <- temp$sigma
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3022
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3023 invisible(list(mu=mu, sigma=sigma, rho=rho, p=p))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3024
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3025 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3026
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3027 # find mu and sigma if the distributions of marginal ranks are known
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3028 # take the medians of the two dist and map back to the original
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3029 init.dist <- function(f0, f1){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3030
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3031 # take the median in f0
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3032 index.median.0 <- which(f0$cdf>0.5)[1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3033 q.0.small <- f0$cdf[index.median.0] # because f0 and f1 have the same bins
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3034 q.1.small <- f1$cdf[index.median.0]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3035
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3036 # take the median in f1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3037 index.median.1 <- which(f1$cdf>0.5)[1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3038 q.0.big <- f0$cdf[index.median.1] # because f0 and f1 have the same bins
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3039 q.1.big <- f1$cdf[index.median.1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3040
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3041 # find pseudo value for x.middle[1] on normal(0,1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3042 pseudo.small.0 <- qnorm(q.0.small, mean=0, sd=1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3043 pseudo.small.1 <- qnorm(q.1.small, mean=0, sd=1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3044
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3045 # find pseudo value for x.middle[2] on normal(0,1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3046 pseudo.big.0 <- qnorm(q.0.big, mean=0, sd=1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3047 pseudo.big.1 <- qnorm(q.1.big, mean=0, sd=1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3048
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3049 mu <- (pseudo.small.0*pseudo.big.1 - pseudo.small.1*pseudo.big.0)/(pseudo.big.1-pseudo.small.1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3050
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3051 sigma <- (pseudo.small.0-mu)/pseudo.small.1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3052
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3053 return(list(mu=mu, sigma=sigma))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3054 }
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3055
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3056 # generate labels
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3057
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3058 # find the part of data with overlap
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3059
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3060 # find the percentile on noise and signal
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3061
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3062 # Suppose there are signal and noise components, with mean=0 and sd=1 for noise
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3063 # x and x.label are the rank of the observations and their labels,
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3064 # find the mean and sd of the other component
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3065 # x.label takes values of 0 and 1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3066 find.mu.sigma <- function(x, x.label){
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3067
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3068 x.0 <- x[x.label==0]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3069 x.1 <- x[x.label==1]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3070
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3071 n.x0 <- length(x.0)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3072 n.x1 <- length(x.1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3073
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3074 x.end <- c(min(x.0), min(x.1), max(x.0), max(x.1))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3075 o <- order(x.end)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3076 x.middle <- x.end[o][c(2,3)]
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3077
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3078 # the smaller end of the overlap
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3079 q.1.small <- mean(x.1 <= x.middle[1])*n.x1/(n.x1+1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3080 q.0.small <- mean(x.0 <= x.middle[1])*n.x0/(n.x0+1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3081
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3082 # the bigger end of the overlap
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3083 q.1.big <- mean(x.1 <= x.middle[2])*n.x1/(n.x1+1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3084 q.0.big <- mean(x.0 <= x.middle[2])*n.x0/(n.x0+1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3085
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3086 # find pseudo value for x.middle[1] on normal(0,1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3087 pseudo.small.0 <- qnorm(q.0.small, mean=0, sd=1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3088 pseudo.small.1 <- qnorm(q.1.small, mean=0, sd=1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3089
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3090 # find pseudo value for x.middle[2] on normal(0,1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3091 pseudo.big.0 <- qnorm(q.0.big, mean=0, sd=1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3092 pseudo.big.1 <- qnorm(q.1.big, mean=0, sd=1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3093
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3094 mu <- (pseudo.small.0*pseudo.big.1 - pseudo.small.1*pseudo.big.0)/(pseudo.big.1-pseudo.small.1)
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3095
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3096 sigma <- (pseudo.small.0-mu)/pseudo.small.1
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3097
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3098 return(list(mu=mu, sigma=sigma))
5e6efd5f3567 Uploaded
modencode-dcc
parents:
diff changeset
3099 }