File: transforms.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 (256 lines) | stat: -rw-r--r-- 7,753 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
# Transformation methods for matrix-like and NMF objects
# 
# Author: Renaud Gaujoux
# Creation: 19 Jan 2012
###############################################################################

#' @include NMF-class.R
NULL

#' Transforming from Mixed-sign to Nonnegative Data
#' 
#' \code{nneg}  is a generic function to transform a data objects that 
#' contains negative values into a similar object that only contains 
#' values that are nonnegative or greater than a given threshold.
#' 
#' @param object The data object to transform
#' @param ... extra arguments to allow extension or passed down to \code{nneg,matrix}
#' or \code{rposneg,matrix} in subsequent calls.
#' 
#' @return an object of the same class as argument \code{object}.
#' @export
#' @inline
#' @family transforms
#' 
setGeneric('nneg', function(object, ...) standardGeneric('nneg'))
#' Transforms a mixed-sign matrix into a nonnegative matrix, optionally apply a
#' lower threshold. 
#' This is the workhorse method, that is eventually called by all other 
#' methods defined in the \code{\link{NMF}} package.
#' 
#' @param method Name of the transformation method to use, that is partially 
#' matched against the following possible methods:
#' \describe{
#' \item{pmax}{Each entry is constrained to be above threshold \code{threshold}.}
#' 
#' \item{posneg}{The matrix is split into its "positive" and "negative" parts, 
#' with the entries of each part constrained to be above threshold \code{threshold}.
#' The result consists in these two parts stacked in rows (i.e. \code{\link{rbind}}-ed)
#' into a single matrix, which has double the number of rows of the input 
#' matrix \code{object}.}
#' 
#' \item{absolute}{The absolute value of each entry is constrained to be above 
#' threshold \code{threshold}.}
#' 
#' \item{min}{Global shift by adding the minimum entry to each entry, only if 
#' it is negative, and then apply threshold.
#' }
#' 
#' }
#' 
#' @param threshold Nonnegative lower threshold value (single numeric). 
#' See argument \code{shit} for details on how the threshold is used and affects
#' the result.
#' @param shift a logical indicating whether the entries below the threshold 
#' value \code{threshold} should be forced (shifted) to 0 (default) or to 
#' the threshold value itself. 
#' In other words, if \code{shift=TRUE} (default) all entries in 
#' the result matrix are either 0 or strictly greater than \code{threshold}.
#' They are all greater or equal than \code{threshold} otherwise.
#' 
#' @seealso \code{\link{pmax}}
#' @examples
#' 
#' # random mixed sign data (normal distribution)
#' set.seed(1)
#' x <- rmatrix(5,5, rnorm, mean=0, sd=5)
#' x
#' 
#' # pmax (default)
#' nneg(x)
#' # using a threshold
#' nneg(x, threshold=2)
#' # without shifting the entries lower than threshold
#' nneg(x, threshold=2, shift=FALSE)
#' 
#' # posneg: split positive and negative part
#' nneg(x, method='posneg')
#' nneg(x, method='pos', threshold=2)
#' 
#' # absolute
#' nneg(x, method='absolute')
#' nneg(x, method='abs', threshold=2)
#' 
#' # min
#' nneg(x, method='min')
#' nneg(x, method='min', threshold=2)
#' 
setMethod('nneg', 'matrix'
, function(object, method=c('pmax', 'posneg', 'absolute', 'min'), threshold=0, shift=TRUE){
	# match argument
	method <- match.arg(method)
	if( !is.numeric(threshold) || length(threshold) != 1L )
		stop("nneg - Invalid threshold value in argument `threshold` [",threshold,"]: must be a single numeric value.")
	if( threshold < 0 )
		stop("nneg - Invalid threshold value in argument `threshold` [",threshold,"]: must be nonnegative.")
	
	# 1. Transform if there is any negative entry
	m <- min(object)			
	if( m < 0 ){
		object <- 
		switch(method
		, pmax = pmax(object, 0)
		, posneg = rbind(pmax(object, 0), pmax(-object, 0))
		, absolute = pmax(abs(object), 0)
		, min = object - m
		, stop("NMF::nneg - Unexpected error: unimplemented transformation method '", method, "'.")
		)
	}

	if( threshold > 0 ){
		# 2. Apply threshold if any
		object <- pmax(object, threshold)
		
		# 3. Shifting: entries under threshold
		if( shift ) object[object<=threshold] <- 0
	}
	
	# return modified object
	object
}
)

#' Apply \code{nneg} to the basis matrix of an \code{\link{NMF}} 
#' object (i.e. \code{basis(object)}).
#' All extra arguments in \code{...} are passed to the method \code{nneg,matrix}.
#' 
#' @examples
#' 
#' # random 
#' M <- nmfModel(x, rmatrix(ncol(x), 3))
#' nnM <- nneg(M) 
#' basis(nnM)
#' # mixture coefficients are not affected
#' identical( coef(M), coef(nnM) )
#' 
setMethod('nneg', 'NMF', 
	function(object, ...){
		basis(object) <- nneg(basis(object), ...)
		object
	}
)

#' \code{posneg} is a shortcut for \code{nneg(..., method='posneg')}, to split 
#' mixed-sign data into its positive and negative part. 
#' See description for method \code{"posneg"}, in \code{\link{nneg}}.
#' 
#' @export
#' @rdname nneg
#' @examples
#' # shortcut for the "posneg" transformation
#' posneg(x)
#' posneg(x, 2)
#' 
posneg <- function(...) nneg(..., method='posneg')

#' Transforming from Nonnegative to Mixed Sign Data
#' 
#' \code{rposneg} performs the "reverse" transformation of the \code{\link{posneg}} function.
#' 
#' @return an object of the same type of \code{object}
#' @rdname nneg
#' @inline
#' 
setGeneric('rposneg', function(object, ...) standardGeneric('rposneg'))
#' @param unstack Logical indicating whether the positive and negative parts 
#' should be unstacked and combined into a matrix as \code{pos - neg}, which contains 
#' half the number of rows of \code{object} (default), or left 
#' stacked as \code{[pos; -neg]}.
#'   
#' @export
#' @examples
#' 
#' # random mixed sign data (normal distribution)
#' set.seed(1)
#' x <- rmatrix(5,5, rnorm, mean=0, sd=5)
#' x
#'  
#' # posneg-transform: split positive and negative part
#' y <- posneg(x)
#' dim(y)
#' # posneg-reverse
#' z <- rposneg(y)
#' identical(x, z)
#' rposneg(y, unstack=FALSE)
#' 
#' # But posneg-transformation with a non zero threshold is not reversible
#' y1 <- posneg(x, 1)
#' identical(rposneg(y1), x)
#' 
setMethod('rposneg', 'matrix'
, function(object, unstack=TRUE){
	
	# check that the number of rows is pair
	if( nrow(object) %% 2 != 0 )
		stop("rposneg - Invalid input matrix: must have a pair number of rows [",nrow(object),"].")
	n2 <- nrow(object)
	n <- n2/2
	if( unstack ) object <- object[1:n,,drop=FALSE] - object[(n+1):n2,,drop=FALSE]
	else object[(n+1):n2,] <- - object[(n+1):n2,,drop=FALSE]
	
	# return modified object
	object
}
)

#' Apply \code{rposneg} to the basis matrix of an \code{\link{NMF}} object.
#' 
#' @examples
#' 
#' # random mixed signed NMF model 
#' M <- nmfModel(rmatrix(10, 3, rnorm), rmatrix(3, 4))
#' # split positive and negative part
#' nnM <- posneg(M)
#' M2 <- rposneg(nnM)
#' identical(M, M2)
setMethod('rposneg', 'NMF'
, function(object, ...){ 
	basis(object) <- rposneg(basis(object), ...)
	object
}
)

#' Transformation NMF Model Objects
#' 
#' \code{t} transpose an NMF model, by transposing and swapping its basis and 
#' coefficient matrices: \eqn{t([W,H]) = [t(H), t(W)]}.
#' 
#' The function \code{t} is a generic defined in the \pkg{base} package.
#' The method \code{t.NMF} defines the trasnformation for the general NMF interface. 
#' This method may need to be overloaded for NMF models, whose structure requires 
#' specific handling.
#' 
#' @param x NMF model object.
#' 
#' @family transforms
#' @export
#' @examples
#' 
#' x <- rnmf(3, 100, 20)
#' x
#' # transpose
#' y <- t(x)
#' y
#' 
#' # factors are swapped-transposed
#' stopifnot( identical(basis(y), t(coef(x))) )
#' stopifnot( identical(coef(y), t(basis(x))) )
#' 
t.NMF <- function(x){
	# transpose and swap factors
	w <- t(basis(x))
	.basis(x) <- t(coef(x))
	.coef(x) <- w
	# return object
	x
}