File: NMFStrategy-class.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 (417 lines) | stat: -rw-r--r-- 13,851 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
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
# S4 class for NMG algorithms
# 
# Author: Renaud Gaujoux
###############################################################################


#' @include algorithmic.R
#' @include NMFSet-class.R
NULL

#' Generic Strategy Class
#' 
#' This class defines a common interface for generic algorithm strategies 
#' (e.g., \code{\linkS4class{NMFStrategy}}).
#' 
#' @slot name character string giving the name of the algorithm
#' @slot package name of the package that defined the strategy.
#' @slot defaults default values for some of the algorithm's arguments.
#' 
#' @keywords internal
setClass('Strategy'
	, contains = 'VIRTUAL'
	, representation = representation(
		name = 'character' # the strategy name
		, package = 'character' # the package that defines the strategy
		, defaults = 'list'
	)
	, prototype = prototype(
		package = character()
		, name = character()
	)
	, validity=function(object){
		
		# slot 'name' must be a non-empty character string
		obj <- name(object)
		if( !length(obj) || (length(obj)>1L || obj=='') )
			return(str_c("Slot 'name' must be a single non-empty character string [", obj, ']'))
		TRUE
	}
)

#' Accessing Strategy Names 
#' 
#' \code{name} and \code{name<-} gets and sets the name associated with an object.
#' In the case of \code{Strategy} objects it is the the name of the algorithm.
#' 
#' @param object an R object with a defined \code{name} method
#' @param ... extra arguments to allow extension
#' @param value replacement value 
#' 
#' @export
#' @inline
#' @rdname Strategy-class
setGeneric('name', function(object, ...) standardGeneric('name'))
#' Returns the name of an algorithm
#' @param all a logical that indicates if all the names associated with a strategy 
#' should be returned (\code{TRUE}), or only the first (primary) one (\code{FALSE}).
setMethod('name', signature(object='Strategy'),
	function(object, all=FALSE){
		n <- slot(object, 'name')
		if( length(n) && !all ) n[1L] else n
	}
)
#' @export
#' @inline
#' @rdname Strategy-class 
setGeneric('name<-', function(object, ..., value) standardGeneric('name<-'))
#' Sets the name(s) of an NMF algorithm
setReplaceMethod('name', signature(object='Strategy', value='character'),
	function(object, value){
		slot(object, 'name') <- value
		validObject(object)
		object
	}
)

defaultArgument <- function(name, object, value, force=FALSE){

	# taken from methods::hasArg
	aname <- as.character(substitute(name))
	miss <- eval(substitute(missing(name)), sys.frame(sys.parent()))
	defaults <- attr(object, 'defaults')

	if( !miss && !force ) eval(substitute(name), sys.frame(sys.parent()))
	else if( aname %in% names(defaults) ) defaults[[aname]] 
	else value
}

#' Virtual Interface for NMF Algorithms
#' 
#' This class partially implements the generic interface defined for general 
#' algorithms defined in the \pkg{NMF} package (see \code{\link{algorithmic-NMF}}).
#'  
#' @slot objective the objective function associated with the algorithm (Frobenius, Kullback-Leibler, etc...). 
#'  It is either an access key of a registered objective function or a function definition. 
#'  In the latter case, the given function must have the following signature \code{(x="NMF", y="matrix")}
#'  and return a nonnegative real value.
#' 
#' @slot model a character string giving either the (sub)class name of the NMF-class instance used 
#' and returned by the strategy, or a function name.
#' 
#' @slot mixed a logical that indicates if the algorithm works on mixed-sign data. 
#' 
#' @keywords internal
setClass('NMFStrategy'
	, representation(
				objective = '.functionSlot' # the objective function used to compute the error (defined by name or function)
				, model = 'character' # NMF model to use
				, mixed = 'logical' # can the input data be negative?
	)
	, prototype=prototype(objective='euclidean', model='NMFstd', mixed=FALSE)
	, validity=function(object){
		
		# slot 'objective' must either be a non-empty character string or a function
		obj <- objective(object)
		if( is.character(obj) && obj == '' )
			return("Slot 'objective' must either be a non-empty character string or a function definition.")
			
		# slot 'model' must be the name of a class that extends class 'NMF'
		obj <- modelname(object)
		if( !is.character(obj) )
			return("Slot 'model' must be a character vector")
		if( any(inv <- !sapply(obj, isNMFclass)) )
			return(paste("Slot 'model' must contain only names of a class that extends class 'NMF' [failure on class(es) "
					, paste( paste("'", obj[inv], "'", sep=''), collapse=', ')  
					,"]"
					, sep=''))
		
		# slot 'mixed' must be a single logical		
		obj <- slot(object, 'mixed')
		if( length(obj) != 1 )
			return( paste("Slot 'mixed' must be a single logical [length=", length(obj), "]", sep='') )
	}
	, contains = c('VIRTUAL', 'Strategy')
)

#' @export
#' @rdname NMFStrategy-class
setMethod('show', 'NMFStrategy',
		function(object){			
			cat('<object of class: ', class(object), ">\n", sep='')
			cat(" name: ", name(object), " [", packageSlot(object), "]\n", sep='')
			svalue <- objective(object)
			svalue <- if( is.function(svalue) ) str_args(svalue, exdent=10) else paste("'", svalue,"'", sep='')
			cat(" objective:", svalue, "\n")
			cat(" model:", modelname(object), "\n")
			if( length(object@defaults) > 0L ){
				cat(" defaults:", str_desc(object@defaults, exdent=10L), "\n")
			}
			return(invisible())
		}
)

# Coerce method for 'NMFStrategy' objects into 'character': give the main name
setAs('NMFStrategy', 'character'
	, def = function(from) name(from)	
) 

#' Factory Method for NMFStrategy Objects
#' 
#' Creates NMFStrategy objects that wraps implementation of NMF algorithms into 
#' a unified interface.
#' 
#' @param name name/key of an NMF algorithm.
#' @param method definition of the algorithm
#' @param ... extra arguments passed to \code{\link{new}}.
#' 
#' @export
#' @inline
setGeneric('NMFStrategy', function(name, method, ...) standardGeneric('NMFStrategy') )
#' Creates an \code{NMFStrategyFunction} object that wraps the function \code{method}
#' into a unified interface.
#' 
#' \code{method} must be a function with signature \code{(y="matrix", x="NMFfit", ...)}, 
#' and return an object of class \code{\linkS4class{NMFfit}}.
setMethod('NMFStrategy', signature(name='character', method='function'), 
		function(name, method, ...){
			
			# build a NMFStrategyFunction object on the fly to wrap function 'method'
			NMFStrategy(name=name, algorithm=method, ...)
			
		}
)

#' Creates an \code{NMFStrategy} object based on a template object (Constructor-Copy).
setMethod('NMFStrategy', signature(name='character', method='NMFStrategy'), 
		function(name, method, ...){
			
			package <- topns_name()
			# build an NMFStrategy object based on template object
			strategy <- new(class(method), method, name=name, ..., package=package)
			
			# valid the new strategy
			validObject(strategy)
			
			# add trace of inheritance from parent NMF algorithm
			attr(strategy, 'parent') <- name(method)[1]
			
			# return new object
			strategy
		}
)

#' Creates an \code{NMFStrategy} based on a template object (Constructor-Copy), 
#' in particular it uses the \strong{same} name.
setMethod('NMFStrategy', signature(name='NMFStrategy', method='missing'), 
		function(name, method, ...){
			
			# do not change the object if single argument
			if( nargs() == 1L ) return(name)
			
			# use the name as a key
			# NB: need special trick to avoid conflict between argument and function 
			mname <- match.fun('name')(name)

			NMFStrategy(name=mname, method=name, ...)
		}
)

#' Creates an \code{NMFStrategy} based on a registered NMF algorithm that is used 
#' as a template (Constructor-Copy), in particular it uses the \strong{same} name.
#' 
#' It is a shortcut for \code{NMFStrategy(nmfAlgorithm(method, exact=TRUE), ...)}.
setMethod('NMFStrategy', signature(name='missing', method='character'), 
		function(name, method, ...){
			NMFStrategy(nmfAlgorithm(method, exact=TRUE), ...)
		}
)


#' Creates an \code{NMFStrategy} based on a template object (Constructor-Copy) 
#' but using a randomly generated name.
setMethod('NMFStrategy', signature(name='NULL', method='NMFStrategy'), 
		function(name, method, ...){
			
			# use the name as a key
			# NB: need special trick to avoid conflict between argument and function 
			mname <- match.fun('name')(method)
			mname <- basename(tempfile(str_c(mname, '_')))
			
			NMFStrategy(name=mname, method=method, ...)
		}
)

#' Creates an \code{NMFStrategy} based on a registered NMF algorithm that is used 
#' as a template.
setMethod('NMFStrategy', signature(name='character', method='character'), 
		function(name, method, ...){
			NMFStrategy(name=name, method=nmfAlgorithm(method, exact=TRUE), ...) 
		}
)
#' Creates an \code{NMFStrategy} based on a registered NMF algorithm (Constructor-Copy) 
#' using a randomly generated name.
#' 
#' It is a shortcut for \code{NMFStrategy(NULL, nmfAlgorithm(method), ...)}.
setMethod('NMFStrategy', signature(name='NULL', method='character'), 
		function(name, method, ...){
			NMFStrategy(NULL, method=nmfAlgorithm(method, exact=TRUE), ...) 
		}
)
#' Creates an NMFStrategy, determining its type from the extra arguments passed 
#' in \code{...}: if there is an argument named \code{Update} then an 
#' \code{NMFStrategyIterative} is created, or if there is an argument 
#' named \code{algorithm} then an \code{NMFStrategyFunction} is created.
#' Calls other than these generates an error.
#'  
setMethod('NMFStrategy', signature(name='character', method='missing'), 
		function(name, method, ...){
			
			package <- topns_name()
			# check iterative strategy
			if( hasArg2('Update') ){ # create a new NMFStrategyIterative object
				new('NMFStrategyIterative', name=name, ..., package=package)
			}else if( hasArg2('algorithm') ){
				new('NMFStrategyFunction', name=name, ..., package=package)
			}else{
				stop('NMFStrategy - Could not infer the type of NMF strategy to instantiate.')
			}
			
		}
)

#' Pure virtual method defined for all NMF algorithms to ensure 
#' that a method \code{run} is defined by sub-classes of \code{NMFStrategy}.
#' 
#' It throws an error if called directly.
#' @rdname NMFStrategy
setMethod('run', signature(object='NMFStrategy', y='matrix', x='NMFfit'),
	function(object, y, x, ...){
		stop("NMFStrategy::run is a pure virtual method that should be overloaded in class '", class(object),"'.")
	}
)
#' Method to run an NMF algorithm directly starting from a given NMF model.
#' @rdname NMFStrategy
setMethod('run', signature(object='NMFStrategy', y='matrix', x='NMF'),
	function(object, y, x, ...){
		run(object, y, NMFfit(fit=x, seed='none', method=name(object)), ...)
	}
)

#' Computes the value of the objective function between the estimate \code{x}
#' and the target \code{y}.
#' 
#' @param x an NMF model that estimates \code{y}.
#' 
#' @inline
setMethod('deviance', 'NMFStrategy',
	function(object, x, y, ...){
		
		obj.fun <- slot(object, 'objective')
		
		# return the distance computed using the strategy's objective function
		if( !is.function(obj.fun) )
			deviance(x, y, method=obj.fun, ...)
		else # directly compute the objective function
			obj.fun(x, y, ...)
		
	}
)
		
#' Gets the objective function associated with an NMF algorithm.
#'  
#' It is used in \code{\link[=deviance,NMFStrategy-method]{deviance}} 
#' to compute the objective value for an NMF model with respect to 
#' a given target matrix. 
#' 
#' @export
#' @rdname NMFStrategy-class
setMethod('objective', 'NMFStrategy',
	function(object){
		slot(object, 'objective')
	}
)
#' Sets the objective function associated with an NMF algorithm, with a character string
#' that must be a registered objective function.
#' @export
#' @rdname NMFStrategy-class
setReplaceMethod('objective', signature(object='NMFStrategy', value='character'),
	function(object, value){
		#TODO: test for the existence of objective method
		slot(object, 'objective') <- value
		validObject(object)
		object
	}
)
#' Sets the objective function associated with an NMF algorithm, with a function
#' that computes the approximation error between an NMF model and a target matrix.
#' @export
#' @rdname NMFStrategy-class
setReplaceMethod('objective', signature(object='NMFStrategy', value='function'),
	function(object, value){
		slot(object, 'objective') <- value
		validObject(object)
		object
	}
)

#' Returns the model(s) that an NMF algorithm can fit.
#' 
#' @examples
#' # get the type of model(s) associated with an NMF algorithm
#' modelname( nmfAlgorithm('brunet') )
#' modelname( nmfAlgorithm('nsNMF') )
#' modelname( nmfAlgorithm('offset') )
#' 
setMethod('modelname', signature(object='NMFStrategy'),
	function(object){
		slot(object, 'model')
	}
)
#' \code{is.mixed} tells if an NMF algorithm works on mixed-sign data. 
#' @export
#' @rdname NMFStrategy-class
is.mixed <-	function(object){
	return( slot(object, 'mixed') )
}

#' Showing Arguments of NMF Algorithms
#' 
#' This function returns the extra arguments that can be passed
#' to a given NMF algorithm in call to \code{\link{nmf}}.
#' 
#' @param x algorithm specification
#' @param ... extra argument to allow extension
#' 
#' @export
nmfFormals <- function(x, ...){
	UseMethod('nmfFormals')
}

#' @export
nmfFormals.character <- function(x, ...){
	s <- nmfAlgorithm(x)
	nmfFormals(s, ...)
}

#' @export
nmfFormals.NMFStrategy <- function(x, ...){
	m <- getMethod('run', signature(object='NMFStrategy', y='matrix', x='NMFfit'))
	args <- allFormals(m)
	# prepend registered default arguments
	expand_list(x@defaults, args)
}

#' \code{nmfArgs} is a shortcut for \code{args(nmfWrapper(x))}, to 
#' display the arguments of a given NMF algorithm.
#' 
#' @rdname nmfFormals
#' @export
#' @examples 
#' 
#' # show arguments of an NMF algorithm
#' nmfArgs('brunet')
#' nmfArgs('snmf/r')
nmfArgs <- function(x){
	args(nmfWrapper(x))
}