shabbychef / fromo
1
# This file is part of fromo.
2
#
3
# fromo is free software: you can redistribute it and/or modify
4
# it under the terms of the GNU Lesser General Public License as published by
5
# the Free Software Foundation, either version 3 of the License, or
6
# (at your option) any later version.
7
#
8
# fromo is distributed in the hope that it will be useful,
9
# but WITHOUT ANY WARRANTY; without even the implied warranty of
10
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11
# GNU Lesser General Public License for more details.
12
#
13
# You should have received a copy of the GNU Lesser General Public License
14
# along with fromo.  If not, see <http://www.gnu.org/licenses/>.
15

16
# Created: 2016.03.30
17
# Copyright: Steven E. Pav, 2016
18
# Author: Steven E. Pav <steven@corecast.io>
19
# Comments: Steven E. Pav
20
# Copyright 2016-2016 Steven E. Pav. All Rights Reserved.
21
# Author: Steven E. Pav
22

23
# univariate input#FOLDUP
24

25
#' @title centsums Class.
26
#'
27
#' @description 
28
#'
29
#' An S4 class to store (centered) sums of data, and to support operations on 
30
#' the same.
31
#'
32
#' @details
33
#'
34
#' A \code{centsums} object contains a vector value of the data count,
35
#' the mean, and the \eqn{k}th centered sum, for \eqn{k} up to some
36
#' maximum order.
37
#'
38
#' @slot sums a numeric vector of the sums.
39
#' @slot order the maximum order.
40
#'
41
#' @return An object of class \code{centsums}.
42
#' @keywords moments
43
#'
44
#' @examples 
45
#' obj <- new("centsums",sums=c(1000,1.234,0.235),order=2)
46
#'
47
#' @template etc
48
#' @template ref-romo
49
#' @name centsums-class
50
#' @rdname centsums-class
51
#' @exportClass centsums
52
#' @export
53
setClass("centsums", 
54
				 representation(sums="numeric",order="numeric"),
55
				 prototype(sums=c(0.0,0.0,0.0),
56
									 order=2),
57
				 validity=function(object) {
58
					 # ... 
59
					 # http://www.cyclismo.org/tutorial/R/s4Classes.html
60
					 if ((!is.null(object@order)) && (length(object@sums) != (1+object@order))) { return("bad dimensionality or order given.") }
61
					 return(TRUE)
62
				 }
63
)
64
# constructor method documentation
65
#  
66
#' @param .Object a \code{centsums} object, or proto-object.
67
#' @rdname centsums-class
68
#' @aliases initialize,centsums-class
69
setMethod('initialize',
70
					signature('centsums'),
71
					function(.Object,sums,order=NA_real_) {
72 3
						if (is.null(order)) {
73 0
							order <- length(sums) - 1
74
						}
75 3
					 	.Object@sums <- sums
76 3
					 	.Object@order <- order
77

78 3
						.Object
79
					})
80

81
#'
82
#' @param sums a numeric vector.
83
#' @param order the order, defaulting to \code{length(sums)+1}.
84
#' @name centsums
85
#' @rdname centsums-class
86
#' @export
87
centsums <- function(sums,order=NULL) {
88 3
	if (is.null(order)) {
89 3
		order <- length(sums) + 1
90
	}
91 3
	retv <- new("centsums", sums=sums, order=order)
92 3
	invisible(retv)
93
}
94

95
#' @title Coerce to a centsums object.
96
#'
97
#' @description 
98
#'
99
#' Convert data to a \code{centsums} object.
100
#'
101
#' @details
102
#'
103
#' Computes the raw sums on data, and stuffs the results into a 
104
#' \code{centsums} object.
105
#'
106
#' @usage
107
#'
108
#' as.centsums(x, order=3, na.rm=TRUE)
109
#'
110
#' @param x a numeric, array, or matrix.
111
#' @param na.rm whether to remove \code{NA}.
112
#' @inheritParams centsums
113
#' @return A centsums object.
114
#' @template etc
115
#' @examples 
116
#' set.seed(123)
117
#' x <- rnorm(1000)
118
#' cs <- as.centsums(x, order=5)
119
#' @rdname as.centsums
120
#' @export as.centsums
121
as.centsums <- function(x, order=3, na.rm=TRUE) {
122 3
	UseMethod("as.centsums", x)
123
}
124
#' @rdname as.centsums
125
#' @export
126
#' @method as.centsums default
127
#' @aliases as.centsums
128
as.centsums.default <- function(x, order=3, na.rm=TRUE) {
129 3
	sums <- cent_sums(x, max_order=order, na_rm=na.rm)
130 3
	invisible(centsums(sums,order=order))
131
}
132

133
#' @title Accessor methods.
134
#'
135
#' @description
136
#'
137
#' Access slot data from a \code{centsums} object.
138
#'
139
#' @param x a \code{centsums} object.
140
#' @param type the type of moment to compute.
141
#' @template etc
142
#' @name accessor
143
#' @rdname centsums-accessor-methods
144
#' @aliases sums
145
#' @exportMethod sums
146 3
setGeneric('sums', signature="x", function(x) standardGeneric('sums'))
147
#' @rdname centsums-accessor-methods
148
#' @aliases sums,centsums-method
149 3
setMethod('sums', 'centsums', function(x) x@sums )
150

151
# used below
152
.csums2moments <- function(c_sums,type=c('central','raw','standardized')) {
153
		# add used_df
154 3
		type <- match.arg(type)
155 3
		cmoments <- c(c_sums[1],c_sums[2:length(c_sums)] / c_sums[1])
156

157 3
		switch(type,
158 3
			raw={
159 3
				retv <- cent2raw(cmoments)
160
			},
161 3
			central={ 
162 3
				retv <- cmoments[2:length(cmoments)]
163 3
				retv[1] <- 0
164
			},
165 3
			standardized={
166 3
				retv <- cmoments[2:length(cmoments)]
167 3
				retv[1] <- 0.0
168 3
				if (length(retv) > 1) {
169 3
					if (length(retv) > 2) {
170 3
						sigma2 <- retv[2]
171 3
						retv[3:length(retv)] <- retv[3:length(retv)] / (sigma2 ^ ((3:length(retv))/2.0))
172
					}
173 3
					retv[2] <- 1.0
174
				}
175
			})
176 3
			retv
177
}
178

179
#' @rdname centsums-accessor-methods
180
#' @aliases moments
181
#' @exportMethod moments
182 3
setGeneric('moments', function(x,type=c('central','raw','standardized')) standardGeneric('moments'))
183
#' @rdname centsums-accessor-methods
184
#' @aliases moments,centsums-method
185
setMethod('moments', signature(x='centsums'),
186
	function(x,type=c('central','raw','standardized')) {
187
		# add used_df
188 3
		type <- match.arg(type)
189 3
		retv <- .csums2moments(x@sums,type)
190
	})
191

192

193
#' @title concatenate centsums objects.
194
#' @description 
195
#'
196
#' Concatenate centsums objects.
197
#'
198
#' @param ... \code{centsums} objects
199
#' @rdname centsums-concat
200
#' @seealso join_cent_sums
201
#' @method c centsums
202
#' @export
203
#' @usage \\method{c}{centsums}(...)
204
c.centsums <- function(...) { 
205 3
	.join2 <- function(x,y) {
206 3
		x@sums <- join_cent_sums(x@sums,y@sums)
207 3
		x
208
	}
209 3
	x <- Reduce(.join2,list(...))
210
} 
211
#' @title unconcatenate centsums objects.
212
#' @description 
213
#'
214
#' Unconcatenate centsums objects.
215
#'
216
#' @param x a \code{centsums} objects
217
#' @param y a \code{centsums} objects
218
#' @seealso unjoin_cent_sums
219
#' @rdname centsums-unconcat
220
#' @exportMethod %-%
221 3
setGeneric('%-%', function(x,y) standardGeneric('%-%'))
222
#' @rdname centsums-unconcat
223
#' @aliases %-%,centsums,centsums-method
224
setMethod('%-%', signature(x='centsums',y='centsums'),
225
	function(x,y) {
226 3
		x@sums <- unjoin_cent_sums(x@sums,y@sums)
227 3
		return(x)
228
	})
229

230
# show#FOLDUP
231
# 2FIX: add documentation and export
232
#' @title Show a centsums object.
233
#'
234
#' @description 
235
#'
236
#' Displays the centsums object.
237
#'
238
#' @usage
239
#'
240
#' show(object)
241
#'
242
#' @param object a \code{centsums} object.
243
#' @examples 
244
#' set.seed(123)
245
#' x <- rnorm(1000)
246
#' obj <- as.centsums(x, order=5)
247
#' obj
248
#' @template etc
249
#' @name show
250
#' @rdname show-methods
251
#' @exportMethod show
252
#' @aliases show
253
NULL
254
#' @rdname show-methods
255
#' @aliases show,centsums-method
256
setMethod('show', signature('centsums'), 
257
# 2FIX: add cumulants?
258
					function(object) {
259 3
						cat('          class:', class(object), '\n')
260 3
						cat('    raw moments:', .csums2moments(object@sums,'raw'), '\n')
261 3
						cat('central moments:', .csums2moments(object@sums,'central'), '\n')
262 3
						cat('    std moments:', .csums2moments(object@sums,'standardized'), '\n')
263
					})
264
#UNFOLD
265
#UNFOLD
266

267
# multivariate input#FOLDUP
268

269

270
#' @title centcosums Class.
271
#'
272
#' @description 
273
#'
274
#' An S4 class to store (centered) cosums of data, and to support operations on 
275
#' the same.
276
#'
277
#' @details
278
#'
279
#' A \code{centcosums} object contains a multidimensional array (now only
280
#' 2-diemnsional), as output by \code{cent_cosums}.
281
#'
282
#' @seealso cent_cosums
283
#' @slot cosums a multidimensional array of the cosums.
284
#' @slot order the maximum order. ignored for now.
285
#'
286
#' @return An object of class \code{centcosums}.
287
#' @keywords moments
288
#'
289
#' @examples 
290
#' obj <- new("centcosums",cosums=cent_cosums(matrix(rnorm(100*3),ncol=3),max_order=2),order=2)
291
#'
292
#' @template etc
293
#' @template ref-romo
294
#' @name centcosums-class
295
#' @rdname centcosums-class
296
#' @exportClass centcosums
297
#' @export
298
setClass("centcosums", 
299
				 representation(cosums="array",order="numeric"),
300
				 prototype(cosums=matrix(0,nrow=2,ncol=2),
301
									 order=2),
302
				 validity=function(object) {
303
					 # ... 
304
					 # http://www.cyclismo.org/tutorial/R/s4Classes.html
305
					 if ((!is.null(object@order)) && (length(dim(object@cosums)) != object@order)) { return("bad dimensionality or order given.") }
306
					 if (nrow(object@cosums) != ncol(object@cosums)) { return("must give square cosums for now.") }
307
					 return(TRUE)
308
				 }
309
)
310
# constructor method documentation
311
#  
312
#' @param .Object a \code{centcosums} object, or proto-object.
313
#' @rdname centcosums-class
314
#' @aliases initialize,centcosums-class
315
setMethod('initialize',
316
					signature('centcosums'),
317
					function(.Object,cosums,order=NA_real_) {
318 3
						if (is.null(order)) {
319 0
							order <- 2
320
						}
321 3
					 	.Object@cosums <- cosums
322 3
					 	.Object@order <- order
323

324 3
						.Object
325
					})
326

327
#' @param cosums the output of \code{\link{cent_cosums}}, say.
328
#' @param order the order, defaulting to \code{2}.
329
#' @name centcosums
330
#' @rdname centcosums-class
331
#' @export
332
centcosums <- function(cosums,order=NULL) {
333 3
	if (is.null(order)) {
334 3
		order <- length(dim(cosums))
335
	}
336 3
	retv <- new("centcosums", cosums=cosums, order=order)
337 3
	invisible(retv)
338
}
339

340
#' @title Coerce to a centcosums object.
341
#'
342
#' @description 
343
#'
344
#' Convert data to a \code{centcosums} object.
345
#'
346
#' @details
347
#'
348
#' Computes the raw cosums on data, and stuffs the results into a 
349
#' \code{centcosums} object.
350
#'
351
#' @usage
352
#'
353
#' as.centcosums(x, order=2, na.omit=TRUE)
354
#'
355
#' @param x a matrix.
356
#' @param na.omit whether to remove rows with \code{NA}.
357
#' @inheritParams centcosums
358
#' @return A centcosums object.
359
#' @template etc
360
#' @examples 
361
#' set.seed(123)
362
#' x <- matrix(rnorm(100*3),ncol=3)
363
#' cs <- as.centcosums(x, order=2)
364
#' @rdname as.centcosums
365
#' @export as.centcosums
366
as.centcosums <- function(x, order=2, na.omit=TRUE) {
367 3
	UseMethod("as.centcosums", x)
368
}
369
#' @rdname as.centcosums
370
#' @export
371
#' @method as.centcosums default
372
#' @aliases as.centcosums
373
as.centcosums.default <- function(x, order=2, na.omit=TRUE) {
374 3
	cosums <- cent_cosums(x, max_order=order, na_omit=na.omit)
375 3
	invisible(centcosums(cosums,order=order))
376
}
377

378
#' @title Accessor methods.
379
#'
380
#' @description
381
#'
382
#' Access slot data from a \code{centcosums} object.
383
#'
384
#' @param x a \code{centcosums} object.
385
#' @param type the type of moment to compute.
386
#' @template etc
387
#' @name centcosums-accessor
388
#' @rdname centcosum-accessor-methods
389
#' @aliases cosums
390
#' @exportMethod cosums
391 3
setGeneric('cosums', signature="x", function(x) standardGeneric('cosums'))
392
#' @rdname centcosum-accessor-methods
393
#' @aliases sums,centcosums-method
394 3
setMethod('cosums', 'centcosums', function(x) x@cosums )
395

396
# used below
397
.cosums2comoments <- function(c_sums,type=c('central','raw')) {
398
		# add used_df
399 3
		type <- match.arg(type)
400 3
		cmoments <- c(c_sums[1],c_sums[2:length(c_sums)] / c_sums[1])
401

402 3
		switch(type,
403 3
			raw={
404 3
				retv <- c_sums
405 3
				retv[1,1] <- 1
406 3
				retv[2:(nrow(retv)),2:(nrow(retv))] <- retv[2:(nrow(retv)),2:(nrow(retv))] + tcrossprod(retv[2:(nrow(retv)),1])
407
			},
408 3
			central={ 
409 3
				retv <- c_sums
410 3
				retv[1,1] <- 1
411 3
				retv[2:(nrow(retv)),1] <- 0
412 3
				retv[1,2:(nrow(retv))] <- 0
413
			})
414 3
			retv
415
}
416

417
#' @rdname centcosum-accessor-methods
418
#' @aliases comoments
419
#' @exportMethod comoments
420 3
setGeneric('comoments', function(x,type=c('central','raw')) standardGeneric('comoments'))
421
#' @rdname centcosum-accessor-methods
422
#' @aliases comoments,centcosums-method
423
setMethod('comoments', signature(x='centcosums'),
424
	function(x,type=c('central','raw')) {
425
		# add used_df
426 3
		type <- match.arg(type)
427 3
		retv <- .cosums2comoments(x@cosums,type)
428
	})
429

430

431
#' @title concatenate centcosums objects.
432
#' @description 
433
#'
434
#' Concatenate centcosums objects.
435
#'
436
#' @param ... \code{centcosums} objects
437
#' @rdname centcosums-concat
438
#' @seealso join_cent_cosums
439
#' @method c centcosums
440
#' @export
441
#' @usage \\method{c}{centcosums}(...)
442
c.centcosums <- function(...) { 
443 3
	.join2 <- function(x,y) {
444 3
		x@cosums <- join_cent_cosums(x@cosums,y@cosums)
445 3
		x
446
	}
447 3
	x <- Reduce(.join2,list(...))
448
} 
449
#' @title unconcatenate centcosums objects.
450
#' @description 
451
#'
452
#' Unconcatenate centcosums objects.
453
#'
454
#' @param x a \code{centcosums} objects
455
#' @param y a \code{centcosums} objects
456
#' @seealso unjoin_cent_cosums
457
#' @rdname centcosums-unconcat
458
#' @aliases %-%,centcosums,centcosums-method
459
setMethod('%-%', signature(x='centcosums',y='centcosums'),
460
	function(x,y) {
461 3
		x@cosums <- unjoin_cent_cosums(x@cosums,y@cosums)
462 3
		return(x)
463
	})
464

465
# 2FIX: show a centcosums object
466
#UNFOLD
467

468
#for vim modeline: (do not edit)
469
# vim:fdm=marker:fmr=FOLDUP,UNFOLD:cms=#%s:syn=r:ft=r

Read our documentation on viewing source code .

Loading