File: fixed-terms.R

package info (click to toggle)
r-cran-nmf 0.23.0-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 3,344 kB
  • sloc: cpp: 680; ansic: 7; makefile: 2
file content (376 lines) | stat: -rw-r--r-- 11,392 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
# Interface for NMF models that contain fixed terms 
# 
# Author: Renaud Gaujoux
# Creation: 03 Jul 2012
###############################################################################

#' @include NMF-class.R
#' @include NMFstd-class.R
NULL

#' Concatenating NMF Models
#' 
#' Binds compatible matrices and NMF models together.
#' 
#' @param x an NMF model
#' @param ... other objects to concatenate. Currently only two objects at a time 
#' can be concatenated (i.e. \code{x} and \code{..1}).
#' @param margin integer that indicates the margin along which to concatenate 
#' (only used when \code{..1} is a matrix):
#' \describe{
#' \item{1L}{}
#' \item{2L}{}
#' \item{3L}{}
#' \item{4L}{}
#' }
#' If missing the margin is heuristically determined by looking at common 
#' dimensions between the objects. 
#' 
#' @keywords internal
setMethod('c', 'NMF',
	function(x, ..., margin=3L, recursive=FALSE){
		
		y <- ..1
		if( is.matrix(y) ){
			
			if( missing(margin) ){
				if( nrow(y) == nrow(x) ){
					if( ncol(y) == ncol(x) ){
						warning("NMF::`c` - Right argument match both target dimensions: concatenating basis columns."
								, " Use `margin=4L` to concatenate coefficient rows.")
					}
					margin <- 3L
				}else if( ncol(y) == ncol(x) ){
					margin <- 4L
				}else{
					stop("NMF::`c` - Incompatible argument dimensions: could not infer concatenation margin.")
				}
			}
			
			if( margin == 1L ){ # extend basis vectors
				
				if( nbterms(x) ){ # cannot extend models with fixed basis terms
					stop("NMF::`c` - Could not extend basis vectors:"
							, " NMF model has fixed basis terms [", nbterms(x), "]")
				}
				if( ncol(y) != nbasis(x) ){
					stop("NMF::`c` - Could not extend basis vectors:"
							, " incompatible number of columns [", nbasis(x), '!=', ncol(y), "].")
				}
				
				# extend basis vectors
				basis(x) <- rbind(basis(x), y)
				
			} else if( margin == 2L ){ # extend basis profiles
				
				if( ncterms(x) ){ # cannot extend models with fixed coef terms
					stop("NMF::`c` - Could not extend basis profiles:"
							, " NMF model has fixed coefficient terms [", ncterms(x), "]")
				}
				if( nrow(y) != nbasis(x) ){
					stop("NMF::`c` - Could not extend basis profiles:"
							, " incompatible number of rows [", nbasis(x), '!=', nrow(y), "].")
				}
				
				# extend basis profiles
				coef(x) <- cbind(coef(x), y)
				
			} else if( margin == 3L ){ # add basis vectors
				
				if( nrow(y) != nrow(x) ){
					stop("NMF::`c` - Could not concatenate basis vectors:"
						, " incompatible number of rows [", nrow(x), '!=', nrow(y), "].")
				}
				
				# bind basis terms
				.basis(x) <- cbind(basis(x), y)
				dn <- colnames(.basis(x))
				# bind dummy coef
				.coef(x) <- rbind(coef(x), matrix(NA, ncol(y), ncol(x)))
				basisnames(x) <- dn
				
			} else if( margin == 4L ){ # add basis profiles
				
				if( ncol(y) != ncol(x) ){
					stop("NMF::`c` - Could not concatenate basis profiles:"
						, " incompatible number of columns [", ncol(x), '!=', ncol(y), "].")
				}
				
				# bind coef terms
				.coef(x) <- rbind(coef(x), y)
				dn <- rownames(.coef(x))
				# bind dummy basis
				.basis(x) <- cbind(basis(x), matrix(NA, nrow(x), nrow(y)))
				basisnames(x) <- dn
				
			}else{
				stop("NMF::`c` - Invalid concatenation margin: should be either"
								, " 1L (basis rows), 2L (coef columns), 3L (basis vectors/columns) or 4L (basis profiles/coef rows).")
			}
		}else if( is.nmf(y) ){
			# check dimensions
			if( nrow(x) != nrow(y) )
				stop("NMF::`c` - Could not concatenate NMF objects:"
					, " incompatible number of rows [", nrow(x), '!=', nrow(y), "]")
			if( ncol(x) != ncol(y) )
				stop("NMF::`c` - Could not concatenate NMF objects:"
					, " incompatible number of columns [", ncol(x), '!=', ncol(y), "]")
			.basis(x) <- cbind(basis(x), basis(y))
			.coef(x) <- rbind(coef(x), coef(y))
		}else{
			stop("NMF::`c` - Concatenation of an NMF object with objects of class '", class(y), "' is not supported.")
		}
		
		# return augmented object
		x
	}
)


fterms <- function(value){

	res <- list(n=0L, terms=NULL, df=NULL, i=integer())
	if( !length(value) ) return(res)
	
	# convert into a data.frame
	if( is.factor(value) ) value <- data.frame(Group=value)
	else if( is.numeric(value) ) value <- data.frame(Var=value)
	else if( !is.data.frame(value) ) value <- as.data.frame(value)
	
	res$n <- length(value)
    res$df <- value
	# generate fixed term matrix
	terms <- model.matrix(~ -1 + ., data=value)
	res$terms <- terms
	# build indexes
	res$i <- 1:ncol(terms)
		
	res
}

## #' Annotations in NMF Models
## #' 
## #' NMF models may contain annotations for columns/rows and/or rows/features, in 
## #' a similar way gene expression data are annotated 
## #' \code{\linkS4class{ExpressionSet}} objects in Bioconductor.
## #'
## NULL

#' Fixed Terms in NMF Models
#' 
#' These functions are for internal use and should not be called by the end-user.
#' 
#' They use \code{\link{model.matrix}(~ -1 + ., data=value)} to generate suitable
#' term matrices.
#' 
#' @param object NMF object to be updated.
#' @param value specification of the replacement value for fixed-terms.
#' 
#' @rdname terms-internal
#' @keywords internal
#' @inline
setGeneric('bterms<-', function(object, value) standardGeneric('bterms<-'))
#' Default method tries to coerce \code{value} into a \code{data.frame} with 
#' \code{\link{as.data.frame}}.
setReplaceMethod('bterms', signature('NMFstd', 'ANY'),
	function(object, value){
		
		if( nterms(object) ){
			stop("Cannot set fixed basis terms on an object that already has fixed terms:",
					" these can be set only once and before setting any fixed coefficient term",
					" [coef=", ncterms(object), ", basis=", nbterms(object), "].")
		}
		# build terms
		t <- fterms(value)
		
		if( !t$n ) return(object)
		
		# check dimension
		if( nrow(t$terms) != nrow(object) ){
			stop("Invalid fixed basis terms: all terms should have length the number of target rows"
					, "[terms=", nrow(t$terms), " != ", nrow(object), "=target]")
		}
		
		# set data
		object@bterms <- t$df
		# set indexes
		i <- t$i
		nv <- nbasis(object)
		object@ibterms <- nv + i
		# set terms
		object <- c(object, t$terms, margin=3L)
		
		object
	}
)
#' \code{cterms<-} sets fixed coefficient terms or indexes and should only be 
#' called on a newly created NMF object, i.e. in the constructor/factory generic 
#' \code{\link{nmfModel}}.
#' 
#' @rdname terms-internal
#' @inline
setGeneric('cterms<-', function(object, value) standardGeneric('cterms<-'))
#' Default method tries to coerce \code{value} into a \code{data.frame} with 
#' \code{\link{as.data.frame}}.
setReplaceMethod('cterms', signature('NMFstd', 'ANY'),
	function(object, value){
		
		if( ncterms(object) ){
			stop("Cannot set fixed coef terms on an object that already has fixed coef terms:",
				" these can be set only once", 
				" [coef=", ncterms(object), ", basis=", nbterms(object), "].")
		}
		# build terms
		t <- fterms(value)
		
		if( !t$n ) return(object)
		
		# check dimension
		if( nrow(t$terms) != ncol(object) ){
			stop("Invalid fixed coefficient terms: all terms should have length the number of target columns"
					, "[terms=", nrow(t$terms), " != ", ncol(object), "=target]")
		}
		
		# transpose term matrix
		t$terms <- t(t$terms)
		# set data
		object@cterms <- t$df
		# set indexes
		i <- t$i
		nv <- nbasis(object)
		object@icterms <- nv + i
		# set terms
		object <- c(object, t$terms, margin=4L)
					
		object
	}
)

#' Fixed Terms in NMF Models
#' 
#' @description
#' Formula-based NMF models may contain fixed basis and/or coefficient terms.
#' The functions documented here provide access to these data, which are 
#' read-only and defined when the model object is instantiated 
#' (e.g., see \code{\link[=nmfModel,formula,ANY-method]{nmfModel,formula-method}}).
#' 
#' \code{ibterms}, \code{icterms} and \code{iterms} respectively return the 
#' indexes of the fixed basis terms, the fixed coefficient terms and all fixed 
#' terms, within the basis and/or coefficient matrix of an NMF model.
#' 
#' @param object NMF object
#' @param ... extra parameters to allow extension (currently not used)
#' 
#' @export
#' @rdname terms
setGeneric('ibterms', function(object, ...) standardGeneric('ibterms') )
#' Default pure virtual method that ensure a method is defined for concrete 
#' NMF model classes.
setMethod('ibterms', 'NMF', 
	function(object, ...){
		stop("NMF::ibterms is a pure virtual method of interface 'NMF'."
			," It should be overloaded in class '", class(object),"'.")
	}
)
#' Method for standard NMF models, which returns the integer vector that is 
#' stored in slot \code{ibterms} when a formula-based NMF model is instantiated. 
setMethod('ibterms', 'NMFstd', 
	function(object){
		object@ibterms
	}
)
#' @export
#' @rdname terms
setGeneric('icterms', function(object, ...) standardGeneric('icterms') )
#' Default pure virtual method that ensure a method is defined for concrete 
#' NMF model classes.
setMethod('icterms', 'NMF', 
	function(object, ...){
		stop("NMF::icterms is a pure virtual method of interface 'NMF'."
				," It should be overloaded in class '", class(object),"'.")
	}
)
#' Method for standard NMF models, which returns the integer vector that is 
#' stored in slot \code{icterms} when a formula-based NMF model is instantiated. 
setMethod('icterms', 'NMFstd', 
	function(object){
		object@icterms
	}
)
#' @export
#' @rdname terms
iterms <- function(object, ...){
	c(ibterms(object), icterms(object))
}

#' \code{nterms}, \code{nbterms}, and \code{ncterms} return, respectively, 
#' the number of all fixed terms, fixed basis terms and fixed coefficient terms 
#' in an NMF model.
#' In particular: i.e. \code{nterms(object) = nbterms(object) + ncterms(object)}.
#' @export
#' @rdname terms
nterms <- function(object){
	length(ibterms(object)) + length(icterms(object))
}
#' @export
#' @rdname terms
nbterms <- function(object){
	length(ibterms(object))
}
#' @export
#' @rdname terms
ncterms <- function(object){
	length(icterms(object))
}

#' \code{bterms} and \code{cterms} return, respectively, the primary data for 
#' fixed basis and coefficient terms in an NMF model -- as stored in slots 
#' \code{bterms} and \code{cterms} .
#' These are factors or numeric vectors which define fixed basis components, 
#' e.g., used for defining separate offsets for different \emph{a priori} groups 
#' of samples, or to incorporate/correct for some known covariate.
#' 
#' @export
#' @rdname terms
bterms <- function(object){
	object@bterms		
}
#' @export
#' @rdname terms
cterms <- function(object){
	object@cterms	
}

#' \code{ibasis} and \code{icoef} return, respectively, the 
#' indexes of all latent basis vectors and estimated coefficients within the 
#' basis or coefficient matrix of an NMF model.
#' @export
#' @rdname terms
ibasis <- function(object, ...){
	i <- 1:nbasis(object)
	if( length(idx <- ibterms(object, ...)) ) i[-idx]
	else i
}
#' @export
#' @rdname terms
icoef <- function(object, ...){
	i <- 1:nbasis(object)
	if( length(idx <- icterms(object, ...)) ) i[-idx]
	else i
}

#' @export
t.NMFstd <- function(x){
    # transpose and swap factors
    x <- t.NMF(x)
    # swap fixed terms
    bt <- bterms(x)
    ibt <- ibterms(x)
    x@bterms <- cterms(x)
    x@ibterms <- icterms(x)
    x@cterms <- bt
    x@icterms <- ibt
    
    # returns
    x
}