Commit | Line | Data |
---|---|---|
4bcfdbee BA |
1 | #' @name clustering |
2 | #' @rdname clustering | |
492cd9e7 | 3 | #' @aliases clusteringTask1 computeClusters1 computeClusters2 |
4bcfdbee | 4 | #' |
492cd9e7 | 5 | #' @title Two-stage clustering, withing one task (see \code{claws()}) |
4bcfdbee | 6 | #' |
492cd9e7 BA |
7 | #' @description \code{clusteringTask1()} runs one full stage-1 task, which consists in |
8 | #' iterated stage 1 clustering (on nb_curves / ntasks energy contributions, computed | |
9 | #' through discrete wavelets coefficients). \code{computeClusters1()} and | |
10 | #' \code{computeClusters2()} correspond to the atomic clustering procedures respectively | |
11 | #' for stage 1 and 2. The former applies the clustering algorithm (PAM) on a | |
12 | #' contributions matrix, while the latter clusters a chunk of series inside one task | |
13 | #' (~max nb_series_per_chunk) | |
4bcfdbee BA |
14 | #' |
15 | #' @param indices Range of series indices to cluster in parallel (initial data) | |
16 | #' @param getContribs Function to retrieve contributions from initial series indices: | |
17 | #' \code{getContribs(indices)} outpus a contributions matrix | |
18 | #' @param contribs matrix of contributions (e.g. output of \code{curvesToContribs()}) | |
19 | #' @inheritParams computeSynchrones | |
20 | #' @inheritParams claws | |
21 | #' | |
492cd9e7 | 22 | #' @return For \code{clusteringTask1()} and \code{computeClusters1()}, the indices of the |
4bcfdbee BA |
23 | #' computed (K1) medoids. Indices are irrelevant for stage 2 clustering, thus |
24 | #' \code{computeClusters2()} outputs a matrix of medoids | |
25 | #' (of size limited by nb_series_per_chunk) | |
26 | NULL | |
27 | ||
28 | #' @rdname clustering | |
29 | #' @export | |
492cd9e7 BA |
30 | clusteringTask1 = function( |
31 | indices, getContribs, K1, nb_series_per_chunk, ncores_clust=1, verbose=FALSE, parll=TRUE) | |
5c652979 | 32 | { |
492cd9e7 BA |
33 | if (verbose) |
34 | cat(paste("*** Clustering task on ",length(indices)," lines\n", sep="")) | |
4bcfdbee | 35 | |
492cd9e7 BA |
36 | wrapComputeClusters1 = function(inds) { |
37 | if (parll) | |
38 | require("epclust", quietly=TRUE) | |
39 | if (verbose) | |
40 | cat(paste(" computeClusters1() on ",length(inds)," lines\n", sep="")) | |
41 | inds[ computeClusters1(getContribs(inds), K1) ] | |
42 | } | |
4bcfdbee | 43 | |
492cd9e7 | 44 | if (parll) |
7b13d0c2 | 45 | { |
492cd9e7 BA |
46 | cl = parallel::makeCluster(ncores_clust) |
47 | parallel::clusterExport(cl, varlist=c("getContribs","K1","verbose"), envir=environment()) | |
7b13d0c2 | 48 | } |
492cd9e7 BA |
49 | while (length(indices) > K1) |
50 | { | |
51 | indices_workers = .spreadIndices(indices, nb_series_per_chunk) | |
52 | if (parll) | |
53 | indices = unlist( parallel::parLapply(cl, indices_workers, wrapComputeClusters1) ) | |
54 | else | |
55 | indices = unlist( lapply(indices_workers, wrapComputeClusters1) ) | |
56 | } | |
57 | if (parll) | |
58 | parallel::stopCluster(cl) | |
59 | ||
56857861 | 60 | indices #medoids |
5c652979 BA |
61 | } |
62 | ||
4bcfdbee BA |
63 | #' @rdname clustering |
64 | #' @export | |
65 | computeClusters1 = function(contribs, K1) | |
66 | cluster::pam(contribs, K1, diss=FALSE)$id.med | |
0e2dce80 | 67 | |
4bcfdbee BA |
68 | #' @rdname clustering |
69 | #' @export | |
492cd9e7 BA |
70 | computeClusters2 = function(medoids, K2, |
71 | getRefSeries, nb_ref_curves, nb_series_per_chunk, ncores_clust=1,verbose=FALSE,parll=TRUE) | |
5c652979 | 72 | { |
492cd9e7 BA |
73 | synchrones = computeSynchrones(medoids, |
74 | getRefSeries, nb_ref_curves, nb_series_per_chunk, ncores_clust, verbose, parll) | |
75 | distances = computeWerDists(synchrones, ncores_clust, verbose, parll) | |
76 | medoids[ cluster::pam(distances, K2, diss=TRUE)$medoids , ] | |
5c652979 BA |
77 | } |
78 | ||
4bcfdbee BA |
79 | #' computeSynchrones |
80 | #' | |
81 | #' Compute the synchrones curves (sum of clusters elements) from a matrix of medoids, | |
82 | #' using L2 distances. | |
83 | #' | |
84 | #' @param medoids Matrix of medoids (curves of same legnth as initial series) | |
85 | #' @param getRefSeries Function to retrieve initial series (e.g. in stage 2 after series | |
86 | #' have been replaced by stage-1 medoids) | |
492cd9e7 | 87 | #' @param nb_ref_curves How many reference series? (This number is known at this stage) |
4bcfdbee BA |
88 | #' @inheritParams claws |
89 | #' | |
90 | #' @export | |
492cd9e7 BA |
91 | computeSynchrones = function(medoids, getRefSeries, |
92 | nb_ref_curves, nb_series_per_chunk, ncores_clust=1,verbose=FALSE,parll=TRUE) | |
e205f218 | 93 | { |
492cd9e7 | 94 | computeSynchronesChunk = function(indices) |
3eef8d3d | 95 | { |
492cd9e7 | 96 | ref_series = getRefSeries(indices) |
3eef8d3d | 97 | #get medoids indices for this chunk of series |
56857861 BA |
98 | for (i in seq_len(nrow(ref_series))) |
99 | { | |
8702eb86 | 100 | j = which.min( rowSums( sweep(medoids, 2, ref_series[i,], '-')^2 ) ) |
492cd9e7 BA |
101 | if (parll) |
102 | synchronicity::lock(m) | |
8702eb86 | 103 | synchrones[j,] = synchrones[j,] + ref_series[i,] |
492cd9e7 BA |
104 | counts[j,1] = counts[j,1] + 1 |
105 | if (parll) | |
106 | synchronicity::unlock(m) | |
107 | } | |
108 | } | |
109 | ||
110 | K = nrow(medoids) | |
111 | # Use bigmemory (shared==TRUE by default) + synchronicity to fill synchrones in // | |
112 | synchrones = bigmemory::big.matrix(nrow=K,ncol=ncol(medoids),type="double",init=0.) | |
113 | counts = bigmemory::big.matrix(nrow=K,ncol=1,type="double",init=0) | |
114 | # Fork (// run) only on Linux & MacOS; on Windows: run sequentially | |
115 | parll = (requireNamespace("synchronicity",quietly=TRUE) | |
116 | && parll && Sys.info()['sysname'] != "Windows") | |
117 | if (parll) | |
118 | m <- synchronicity::boost.mutex() | |
119 | ||
120 | indices_workers = .spreadIndices(seq_len(nb_ref_curves), nb_series_per_chunk) | |
121 | for (inds in indices_workers) | |
122 | { | |
123 | if (verbose) | |
124 | { | |
125 | cat(paste("--- Compute synchrones for indices range ", | |
126 | min(inds)," -> ",max(inds),"\n", sep="")) | |
56857861 | 127 | } |
492cd9e7 BA |
128 | if (parll) |
129 | ignored <- parallel::mcparallel(computeSynchronesChunk(inds)) | |
130 | else | |
131 | computeSynchronesChunk(inds) | |
132 | } | |
133 | if (parll) | |
134 | parallel::mccollect() | |
135 | ||
136 | mat_syncs = matrix(nrow=K, ncol=ncol(medoids)) | |
137 | vec_count = rep(NA, K) | |
138 | #TODO: can we avoid this loop? | |
139 | for (i in seq_len(K)) | |
140 | { | |
141 | mat_syncs[i,] = synchrones[i,] | |
142 | vec_count[i] = counts[i,1] | |
3eef8d3d BA |
143 | } |
144 | #NOTE: odds for some clusters to be empty? (when series already come from stage 2) | |
8702eb86 | 145 | # ...maybe; but let's hope resulting K1' be still quite bigger than K2 |
492cd9e7 BA |
146 | mat_syncs = sweep(mat_syncs, 1, vec_count, '/') |
147 | mat_syncs[ sapply(seq_len(K), function(i) all(!is.nan(mat_syncs[i,]))) , ] | |
e205f218 | 148 | } |
1c6f223e | 149 | |
4bcfdbee BA |
150 | #' computeWerDists |
151 | #' | |
152 | #' Compute the WER distances between the synchrones curves (in rows), which are | |
153 | #' returned (e.g.) by \code{computeSynchrones()} | |
154 | #' | |
155 | #' @param synchrones A matrix of synchrones, in rows. The series have same length as the | |
492cd9e7 BA |
156 | #' series in the initial dataset |
157 | #' @inheritParams claws | |
4bcfdbee BA |
158 | #' |
159 | #' @export | |
492cd9e7 | 160 | computeWerDists = function(synchrones, ncores_clust=1,verbose=FALSE,parll=TRUE) |
d03c0621 | 161 | { |
4bcfdbee BA |
162 | n <- nrow(synchrones) |
163 | delta <- ncol(synchrones) | |
db6fc17d | 164 | #TODO: automatic tune of all these parameters ? (for other users) |
d03c0621 | 165 | nvoice <- 4 |
4bcfdbee | 166 | # noctave = 2^13 = 8192 half hours ~ 180 days ; ~log2(ncol(synchrones)) |
d7d55bc1 BA |
167 | noctave = 13 |
168 | # 4 here represent 2^5 = 32 half-hours ~ 1 day | |
db6fc17d BA |
169 | #NOTE: default scalevector == 2^(0:(noctave * nvoice) / nvoice) * s0 (?) |
170 | scalevector <- 2^(4:(noctave * nvoice) / nvoice) * 2 | |
171 | #condition: ( log2(s0*w0/(2*pi)) - 1 ) * nvoice + 1.5 >= 1 | |
172 | s0=2 | |
173 | w0=2*pi | |
174 | scaled=FALSE | |
175 | s0log = as.integer( (log2( s0*w0/(2*pi) ) - 1) * nvoice + 1.5 ) | |
176 | totnoct = noctave + as.integer(s0log/nvoice) + 1 | |
177 | ||
492cd9e7 BA |
178 | computeCWT = function(i) |
179 | { | |
180 | if (verbose) | |
181 | cat(paste("+++ Compute Rwave::cwt() on serie ",i,"\n", sep="")) | |
4bcfdbee | 182 | ts <- scale(ts(synchrones[i,]), center=TRUE, scale=scaled) |
db6fc17d BA |
183 | totts.cwt = Rwave::cwt(ts,totnoct,nvoice,w0,plot=0) |
184 | ts.cwt = totts.cwt[,s0log:(s0log+noctave*nvoice)] | |
185 | #Normalization | |
186 | sqs <- sqrt(2^(0:(noctave*nvoice)/nvoice)*s0) | |
187 | sqres <- sweep(ts.cwt,MARGIN=2,sqs,'*') | |
188 | sqres / max(Mod(sqres)) | |
492cd9e7 | 189 | } |
3ccd1e39 | 190 | |
492cd9e7 BA |
191 | if (parll) |
192 | { | |
193 | cl = parallel::makeCluster(ncores_clust) | |
194 | parallel::clusterExport(cl, varlist=c("getContribs","K1","verbose"), envir=environment()) | |
195 | } | |
196 | ||
197 | # (normalized) observations node with CWT | |
198 | Xcwt4 <- | |
199 | if (parll) | |
200 | parallel::parLapply(cl, seq_len(n), computeCWT) | |
201 | else | |
202 | lapply(seq_len(n), computeCWT) | |
203 | ||
204 | if (parll) | |
205 | parallel::stopCluster(cl) | |
206 | ||
207 | Xwer_dist <- bigmemory::big.matrix(nrow=n, ncol=n, type="double") | |
db6fc17d | 208 | fcoefs = rep(1/3, 3) #moving average on 3 values (TODO: very slow! correct?!) |
492cd9e7 BA |
209 | if (verbose) |
210 | cat("*** Compute WER distances from CWT\n") | |
211 | ||
212 | computeDistancesLineI = function(i) | |
1c6f223e | 213 | { |
492cd9e7 BA |
214 | if (verbose) |
215 | cat(paste(" Line ",i,"\n", sep="")) | |
db6fc17d | 216 | for (j in (i+1):n) |
d03c0621 | 217 | { |
492cd9e7 | 218 | #TODO: 'circular=TRUE' is wrong, should just take values on the sides; to rewrite in C |
db6fc17d BA |
219 | num <- filter(Mod(Xcwt4[[i]] * Conj(Xcwt4[[j]])), fcoefs, circular=TRUE) |
220 | WX <- filter(Mod(Xcwt4[[i]] * Conj(Xcwt4[[i]])), fcoefs, circular=TRUE) | |
221 | WY <- filter(Mod(Xcwt4[[j]] * Conj(Xcwt4[[j]])), fcoefs, circular=TRUE) | |
222 | wer2 <- sum(colSums(num)^2) / sum( sum(colSums(WX) * colSums(WY)) ) | |
492cd9e7 BA |
223 | if (parll) |
224 | synchronicity::lock(m) | |
db6fc17d BA |
225 | Xwer_dist[i,j] <- sqrt(delta * ncol(Xcwt4[[1]]) * (1 - wer2)) |
226 | Xwer_dist[j,i] <- Xwer_dist[i,j] | |
492cd9e7 BA |
227 | if (parll) |
228 | synchronicity::unlock(m) | |
229 | } | |
230 | Xwer_dist[i,i] = 0. | |
231 | } | |
232 | ||
233 | parll = (requireNamespace("synchronicity",quietly=TRUE) | |
234 | && parll && Sys.info()['sysname'] != "Windows") | |
235 | if (parll) | |
236 | m <- synchronicity::boost.mutex() | |
237 | ||
238 | for (i in 1:(n-1)) | |
239 | { | |
240 | if (parll) | |
241 | ignored <- parallel::mcparallel(computeDistancesLineI(i)) | |
242 | else | |
243 | computeDistancesLineI(i) | |
244 | } | |
245 | Xwer_dist[n,n] = 0. | |
246 | ||
247 | if (parll) | |
248 | parallel::mccollect() | |
249 | ||
250 | mat_dists = matrix(nrow=n, ncol=n) | |
251 | #TODO: avoid this loop? | |
252 | for (i in 1:n) | |
253 | mat_dists[i,] = Xwer_dist[i,] | |
254 | mat_dists | |
255 | } | |
256 | ||
257 | # Helper function to divide indices into balanced sets | |
258 | .spreadIndices = function(indices, nb_per_chunk) | |
259 | { | |
260 | L = length(indices) | |
261 | nb_workers = floor( L / nb_per_chunk ) | |
262 | if (nb_workers == 0) | |
263 | { | |
264 | # L < nb_series_per_chunk, simple case | |
265 | indices_workers = list(indices) | |
266 | } | |
267 | else | |
268 | { | |
269 | indices_workers = lapply( seq_len(nb_workers), function(i) | |
270 | indices[(nb_per_chunk*(i-1)+1):(nb_per_chunk*i)] ) | |
271 | # Spread the remaining load among the workers | |
272 | rem = L %% nb_per_chunk | |
273 | while (rem > 0) | |
274 | { | |
275 | index = rem%%nb_workers + 1 | |
276 | indices_workers[[index]] = c(indices_workers[[index]], indices[L-rem+1]) | |
277 | rem = rem - 1 | |
d03c0621 | 278 | } |
1c6f223e | 279 | } |
492cd9e7 | 280 | indices_workers |
1c6f223e | 281 | } |