[Archetypes-commits] r40 - in pkg: . R inst/doc man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Apr 6 11:56:15 CEST 2010
Author: manuel
Date: 2010-04-06 11:56:13 +0200 (Tue, 06 Apr 2010)
New Revision: 40
Added:
pkg/NEWS
pkg/R/archetypes-deprecated.R
pkg/R/archetypes-panorama.R
pkg/R/archetypes-robust.R
pkg/R/archetypes-weighted.R
pkg/R/archetypes-xyplot.R
pkg/R/memento.R
pkg/demo/
pkg/man/archetypes-deprecated.Rd
pkg/man/archetypes-generics.Rd
Removed:
pkg/R/archetypes-plot.R
pkg/man/pcplot-methods.Rd
pkg/man/plot-methods.Rd
Modified:
pkg/DESCRIPTION
pkg/R/archetypes-barplot.R
pkg/R/archetypes-class.R
pkg/R/archetypes-kit-blocks.R
pkg/R/archetypes-kit.R
pkg/R/archetypes-movie.R
pkg/R/archetypes-pcplot.R
pkg/R/archetypes-screeplot.R
pkg/R/archetypes-step.R
pkg/R/pcplot.R
pkg/R/skeletonplot.R
pkg/inst/doc/archetypes.Rnw
Log:
(1) Merge branches/pkg-robust; (2) archetypes v 2.0
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2010-04-06 09:17:41 UTC (rev 39)
+++ pkg/DESCRIPTION 2010-04-06 09:56:13 UTC (rev 40)
@@ -1,18 +1,14 @@
Package: archetypes
Type: Package
Title: Archetypal Analysis
-Version: 1.0
-Date: 2009-04-23
-Depends: nnls (>= 1.1)
-Suggests: MASS, vcd
+Version: 2.0
+Date: 2010-04-01
+Depends: methods, modeltools, nnls (>= 1.1)
+Suggests: MASS, vcd, mlbench
Author: Manuel J. A. Eugster <manuel.eugster at stat.uni-muenchen.de>
Maintainer: Manuel J. A. Eugster <manuel.eugster at stat.uni-muenchen.de>
Description: The main function archetypes implements a framework for
archetypal analysis supporting arbitary problem solving mechanisms
for the different conceputal parts of the algorithm.
- NOTE: This package is used as real-world test application for the
- Roxygen documentation system. At the moment, Roxygen does not produce
- "good" help pages for the everyday use of a package; we refer to the
- vignette for a consistent package illustration.
License: GPL (>= 2)
Revision: 17
Copied: pkg/NEWS (from rev 39, branches/pkg-robust/NEWS)
===================================================================
--- pkg/NEWS (rev 0)
+++ pkg/NEWS 2010-04-06 09:56:13 UTC (rev 40)
@@ -0,0 +1,16 @@
+
+Changes in archetypes version 2.0
+
+ o cleaned up interface; see '?archetypes-deprecated' and
+ '?archetypes-generics'.
+
+ o added weighted and robust archetypes; see 'demo(robust-toy)' and
+ 'demo(robust-ozone)'.
+
+ o added 'memento' environment to save internal states.
+
+ o added panorama plot; see '?panorama.archetypes'
+
+ o improved 'barplot.archetypes'.
+
+
Modified: pkg/R/archetypes-barplot.R
===================================================================
--- pkg/R/archetypes-barplot.R 2010-04-06 09:17:41 UTC (rev 39)
+++ pkg/R/archetypes-barplot.R 2010-04-06 09:56:13 UTC (rev 40)
@@ -7,8 +7,9 @@
#' \code{beside} creates one barplot with bars side by side.
#' @param which.beside Barplot according to \code{atypes} or \code{variables}.
#' @param which.below \code{compressed} plots the labels only once.
-#' @param percentage Show real values or percentages according to the
-#' original data.
+#' @param percentiles Show real values or percentile profiles.
+#' @param below.compressed.height Height of additional tail subplot.
+#' @param below.compressed.srt Rotations of the x-labels.
#' @param ... Passed to the underlying \code{\link{barplot}} call.
#' @return Undefined.
#' @method barplot archetypes
@@ -18,16 +19,21 @@
which = c('below', 'beside'),
which.beside = c('atypes', 'variables'),
which.below = c('compressed', 'default'),
- percentage=FALSE, ...) {
+ percentiles = FALSE,
+ below.compressed.height = 0.1,
+ below.compressed.srt = 0, ...) {
+ ### Helpers:
.beside.atypes <- function() {
barplot(t(atypes), ylab=ylab, beside=TRUE, ylim=ylim, ...)
}
+
.beside.variables <- function() {
barplot(atypes, ylab=ylab, beside=TRUE, ylim=ylim, ...)
}
+
.below.default <- function() {
p <- nrow(atypes)
@@ -37,41 +43,59 @@
ylab=ylab, ylim=ylim, ...)
}
+
.below.compressed <- function() {
p <- nrow(atypes) + 1
+ heights <- c(rep(1, p - 1), below.compressed.height)
- layout(matrix(1:p, nrow = p, byrow = TRUE))
+ layout(matrix(1:p, nrow = p, byrow = TRUE),
+ heights = heights)
for ( i in 1:(p - 1) ) {
par(mar = c(0, 5, 1, 0) + 0.1)
- x.at <- barplot(atypes[i,], ylab=ylab, ylim=ylim,
- names.arg='', las=2, ...)
+ x.at <- barplot(atypes[i,], ylab = ylab, ylim = ylim,
+ names.arg = '', las = 2, ...)
mtext(sprintf('Archetype %s', i), side = 2, line = 4,
cex = par('cex'))
}
- text(x.at, par("usr")[3] - 1, srt = 90, adj = 1,
- labels = colnames(atypes), xpd = NA)
+
+ text(x.at, par("usr")[3] - 3, srt = below.compressed.srt,
+ adj = 1, labels = colnames(atypes), xpd = NA)
}
+ .perc <- function(x, data, digits = 0) {
+ Fn <- ecdf(data)
+ round(Fn(x) * 100, digits = digits)
+ }
+
+
+ ### Plot:
+ opar <- par(no.readonly = TRUE)
+ on.exit(par(opar))
+
which <- match.arg(which)
+
if ( which == 'beside' )
which.arg <- match.arg(which.beside)
else
which.arg <- match.arg(which.below)
- atypes <- atypes(height)
+ atypes <- parameters(height)
rownames(atypes) <- sprintf('Archetype %s',
seq(length = nrow(atypes)))
- if ( !percentage ) {
+ if ( !percentiles ) {
ylab <- 'Value'
ylim <- NULL
}
else {
- m <- sapply(data, max)
- atypes <- t(t(atypes) / m * 100)
- ylab <- 'Percentage'
- ylim <- c(0,100)
+ atypes <- sapply(seq(length = ncol(data)),
+ function(i)
+ .perc(atypes[, i], data[, i]))
+ colnames(atypes) <- colnames(data)
+
+ ylab <- 'Percentile'
+ ylim <- c(0, 100)
}
do.call(sprintf('.%s.%s', which, which.arg), list())
Modified: pkg/R/archetypes-class.R
===================================================================
--- pkg/R/archetypes-class.R 2010-04-06 09:17:41 UTC (rev 39)
+++ pkg/R/archetypes-class.R 2010-04-06 09:56:13 UTC (rev 40)
@@ -1,6 +1,6 @@
-#' Archetypes object constructor.
+#' Archetypes object constructor and methods.
#' @param archetypes The archetypes; a \eqn{p \times m} matrix, see
#' \code{\link{atypes}}.
#' @param k The number of archetypes;
@@ -14,30 +14,45 @@
#' @param kappas The kappas for each system of linear equations.
#' @param betas The data coefficients; a \eqn{p \times n} matrix.
#' @param zas The temporary archetypes.
+#' @param family The archetypes family.
+#' @param familyArgs Additional arguments for family blocks.
+#' @param residuals The residuals.
+#' @param weights The data weights.
+#' @param reweights The data reweights.
#' @return A list with an element for each parameter and class attribute
#' \code{archetypes}.
-#' @seealso \code{\link{archetypes}}, \code{\link{atypes}}, \code{\link{ntypes}},
-#' \code{\link{rss}}, \code{\link{adata}}, \code{\link{alphas}},
-#' \code{\link{ahistory}}, \code{\link{nhistory}}
-#' @export
-as.archetypes <- function(archetypes, k, alphas, rss, iters=NULL, call=NULL,
- history=NULL, kappas=NULL, betas=NULL, zas=NULL) {
-
- return(structure(list(archetypes=archetypes,
- k=k,
- alphas=alphas,
- rss=rss,
- iters=iters,
- kappas=kappas,
- betas=betas,
- zas=zas,
- call=call,
- history=history),
- class='archetypes'))
+#' @seealso \code{\link{archetypes}}
+#' @rdname archetypes-class
+#' @aliases archetypes-class
+as.archetypes <- function(archetypes, k, alphas, rss, iters = NULL, call = NULL,
+ history = NULL, kappas = NULL, betas = NULL, zas = NULL,
+ family = NULL, familyArgs = NULL, residuals = NULL,
+ weights = NULL, reweights = NULL) {
+
+ return(structure(list(archetypes = archetypes,
+ k = k,
+ alphas = alphas,
+ rss = rss,
+ iters = iters,
+ kappas = kappas,
+ betas = betas,
+ zas = zas,
+ call = call,
+ history = history,
+ family = family,
+ familyArgs = familyArgs,
+ residuals = residuals,
+ weights = weights,
+ reweights = reweights),
+ class = c(family$class, 'archetypes')))
}
+setOldClass('archetypes')
+
+
+
#' Print method for archetypes object.
#' @param x An \code{archetypes} object.
#' @param full Full information or just convergence and rss information.
@@ -45,219 +60,184 @@
#' @return Undefined.
#' @method print archetypes
#' @S3method print archetypes
-print.archetypes <- function(x, full=TRUE, ...) {
+#' @nord
+print.archetypes <- function(x, full = TRUE, ...) {
if ( full ) {
cat('Archetypes object\n\n')
- cat(deparse(x$call), '\n\n')
+ cat(paste(deparse(x$call), collapse = '\n'), '\n\n')
}
-
+
cat('Convergence after', x$iters, 'iterations\n')
- cat('with RSS = ', rss(x), '.\n', sep='')
+ cat('with RSS = ', rss(x), '.\n', sep = '')
}
-#' Archetypes getter.
-#' @param zs An \code{archetypes}-related object.
-#' @param ... Further arguments.
-#' @return Archetypes matrix.
-#' @export
-atypes <- function(zs, ...) {
- UseMethod('atypes')
+#' Return fitted data, i.e. archetypes data approximation.
+#' @param object An \code{archetypes}-related object.
+#' @param ... Ignored.
+#' @return Matrix with approximated data.
+#' @method fitted archetypes
+#' @S3method fitted archetypes
+#' @rdname archetypes-class
+fitted.archetypes <- function(object, ...) {
+ t(t(object$archetypes) %*% t(object$alphas))
}
-#' Archetypes getter.
-#' @param zs An \code{archetypes} object.
+
+
+#' Return fitted archetypes.
+#' @param object An \code{archetypes} object.
#' @param ... Ignored.
-#' @return Archetypes matrix.
-#' @method atypes archetypes
-#' @S3method atypes archetypes
-atypes.archetypes <- function(zs, ...) {
- return(zs$archetypes)
+#' @return Matrix with \eqn{k} archetypes.
+#' @nord
+.parameters.archetypes <- function(object, ...) {
+ object$archetypes
}
+#' Return fitted archetypes.
+#' @param object An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return Matrix with \eqn{k} archetypes.
+#' @importFrom modeltools parameters
+#' @rdname archetypes-class
+setMethod('parameters',
+ signature = signature(object = 'archetypes'),
+ .parameters.archetypes)
-#' Number of archetypes getter.
-#' @param zs An \code{archetypes}-related object.
-#' @param ... Further arguments.
-#' @return Number of archetypes.
-#' @export
-ntypes <- function(zs, ...) {
- UseMethod('ntypes')
+
+#' Return coefficients.
+#' @param object An \code{archetypes} object.
+#' @param type Return alphas or betas.
+#' @param ... Ignored.
+#' @return Coefficient matrix.
+#' @method coef archetypes
+#' @S3method coef archetypes
+#' @rdname archetypes-class
+coef.archetypes <- function(object, type = c('alphas', 'betas'), ...) {
+ type <- match.arg(type)
+ object[[type]]
}
-#' @S3method ntypes archetypes
-ntypes.archetypes <- function(zs, ...) {
- return(zs$k)
+
+#' Return residuals.
+#' @param object An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return Matrix with residuals.
+#' @method residuals archetypes
+#' @S3method residuals archetypes
+#' @rdname archetypes-class
+residuals.archetypes <- function(object, ...) {
+ object$residuals
}
-#' Residual sum of squares getter.
-#' @param zs An \code{archetypes}-related object.
-#' @param ... Further arguments.
+#' Residual sum of squares.
+#' @param object An object.
+#' @param ... Ignored.
#' @return Residual sum of squares.
#' @export
-rss <- function(zs, ...) {
+#' @rdname archetypes-generics
+rss <- function(object, ...) {
UseMethod('rss')
}
#' Residual sum of squares getter.
-#' @param zs An \code{archetypes} object.
+#' @param object An \code{archetypes} object.
+#' @param type Return scaled, single or global RSS.
#' @param ... Ignored.
#' @return Residual sum of squares.
#' @method rss archetypes
#' @S3method rss archetypes
-rss.archetypes <- function(zs, ...) {
- return(zs$rss)
+#' @rdname archetypes-class
+rss.archetypes <- function(object, type = c('scaled', 'single', 'global'), ...) {
+ type <- match.arg(type)
+ resid <- residuals(object)
+
+ switch(type,
+ scaled = object$rss,
+ single = apply(resid, 1, object$family$normfn),
+ global = object$family$normfn(resid) / nrow(resid))
}
-#' Archetypes data approximation.
-#' @param zs An \code{archetypes}-related object.
-#' @param ... Further arguments.
-#' @return Approximated data matrix.
-#' @export
-adata <- function(zs, ...) {
- UseMethod('adata')
-}
-
-#' Archetypes data approximation.
-#' @param zs An \code{archetypes} object.
+#' Return weights.
+#' @param object An \code{archetypes} object.
+#' @param type Return global weights (weighted archetypes) or
+#' weights calculated during the iterations (robust archetypes).
#' @param ... Ignored.
-#' @return Approximated data matrix.
-#' @method adata archetypes
-#' @S3method adata archetypes
-adata.archetypes <- function(zs, ...) {
- return(t(t(zs$archetypes) %*% t(zs$alphas)))
+#' @return Vector of weights.
+#' @method weights archetypes
+#' @S3method weights archetypes
+#' @rdname archetypes-class
+weights.archetypes <- function(object, type = c('weights', 'reweights'), ...) {
+ type <- match.arg(type)
+ object[[type]]
}
-#' Alpha getter.
-#' @param zs An \code{archetypes}-related object.
-#' @param ... Further arguments.
-#' @return Alpha matrix.
-#' @export
-alphas <- function(zs, ...) {
- UseMethod('alphas')
-}
-
-#' Alpha getter.
-#' @param zs An \code{archetypes} object.
+#' Kappa getter.
+#' @param z An \code{archetypes} object.
#' @param ... Ignored.
-#' @return Alpha matrix.
-#' @method alphas archetypes
-#' @S3method alphas archetypes
-alphas.archetypes <- function(zs, ...) {
- return(zs$alphas)
+#' @return A vector of kappas.
+#' @method kappa archetypes
+#' @S3method kappa archetypes
+#' @rdname archetypes-class
+kappa.archetypes <- function(z, ...) {
+ return(z$kappas)
}
-#' Beta getter.
-#' @param zs An \code{archetypes}-related object.
-#' @param ... Further arguments.
-#' @return Beta matrix.
-#' @export
-betas <- function(zs, ...) {
- UseMethod('betas')
-}
-
-#' Beta getter.
-#' @param zs An \code{archetypes} object.
+#' Predict coefficients or data based on archetypes.
+#' @param object An \code{archetypes} object.
+#' @param type Predict alphas or data.
#' @param ... Ignored.
-#' @return Beta matrix.
-#' @method betas archetypes
-#' @S3method betas archetypes
-betas.archetypes <- function(zs, ...) {
- return(zs$betas)
-}
+#' @return Prediction.
+#' @method predict archetypes
+#' @S3method predict archetypes
+#' @nord
+predict.archetypes <- function(object, newdata = NULL,
+ type = c('alphas', 'data'), ...) {
+ type <- match.arg(type)
+ if ( is.null(newdata) )
+ return(switch(type,
+ alphas = coef(object, type = 'alphas'),
+ data = fitted(object)))
+ stop('Not implemented yet.')
-#' Iteration getter.
-#' @param zs An \code{archetypes}-related object.
-#' @param ... Further arguments.
-#' @return Number of iterations.
-#' @export
-iters <- function(zs, ...) {
- UseMethod('iters')
+ ### Something like the following ...
+ #if ( type == 'alphas' )
+ # object$family$alphasfn(NULL, t(object$archetypes), t(newdata))
}
-#' Iteration getter.
-#' @param zs An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return Number of iterations.
-#' @method iters archetypes
-#' @S3method iters archetypes
-iters.archetypes <- function(zs, ...) {
- return(zs$iters)
-}
-
-#' Archetypes history getter.
-#' @param zs An \code{archetypes}-related object.
+#' Number of parameters.
+#' @param object An object.
#' @param ... Further arguments.
-#' @return The \code{archetypes} object of the requested step.
+#' @return Number of parameters.
#' @export
-ahistory <- function(zs, ...) {
- UseMethod('ahistory')
+#' @rdname archetypes-generics
+nparameters <- function(object, ...) {
+ UseMethod('nparameters')
}
-#' Archetypes history getter.
-#' @param zs An \code{archetypes} object.
-#' @param step The step number to return.
-#' @param ... Ignored.
-#' @return The \code{archetypes} object of the requested step.
-#' @method ahistory archetypes
-#' @S3method ahistory archetypes
-ahistory.archetypes <- function(zs, step, ...) {
- if ( is.null(zs$history) )
- stop('No history available')
- if ( step >= 0 )
- s <- paste('s', step, sep='')
- else
- s <- paste('s', nhistory(zs) + step - 1, sep='')
-
- return(zs$history[[s]][[1]])
-}
-
-
-#' Number of history steps getter.
-#' @param zs An \code{archetypes}-related object.
+#' Number of archetypes
+#' @param object An \code{archetypes}-related object.
#' @param ... Further arguments.
-#' @return The number of history steps available.
-#' @export
-nhistory <- function(zs, ...) {
- UseMethod('nhistory')
+#' @return Number of archetypes.
+#' @method nparameters archetypes
+#' @S3method nparameters archetypes
+#' @rdname archetypes-class
+nparameters.archetypes <- function(object, ...) {
+ return(object$k)
}
-
-#' Archetypes number of history steps getter.
-#' @param zs An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return The number of history steps available.
-#' @method nhistory archetypes
-#' @S3method nhistory archetypes
-nhistory.archetypes <- function(zs, ...) {
- if ( is.null(zs$history) )
- stop('No history available')
-
- return(length(zs$history))
-}
-
-
-#' Kappa getter.
-#' @param z An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return A vector of kappas.
-#' @method kappa archetypes
-#' @S3method kappa archetypes
-kappa.archetypes <- function(z, ...) {
- return(z$kappas)
-}
Copied: pkg/R/archetypes-deprecated.R (from rev 39, branches/pkg-robust/R/archetypes-deprecated.R)
===================================================================
--- pkg/R/archetypes-deprecated.R (rev 0)
+++ pkg/R/archetypes-deprecated.R 2010-04-06 09:56:13 UTC (rev 40)
@@ -0,0 +1,212 @@
+
+
+#' Archetypes getter.
+#'
+#' replaced by \code{\link{parameters}}.
+#'
+#' @param zs An \code{archetypes}-related object.
+#' @param ... Further arguments.
+#' @return Archetypes matrix.
+#' @export
+#' @rdname archetypes-deprecated
+atypes <- function(zs, ...) {
+ .Deprecated('parameters')
+ UseMethod('atypes')
+}
+
+#' @S3method atypes archetypes
+#' @nord
+atypes.archetypes <- function(zs, ...) {
+ return(zs$archetypes)
+}
+
+#' @S3method atypes stepArchetypes
+#' @nord
+atypes.stepArchetypes <- function(zs, ...) {
+ return(lapply(zs, atypes))
+}
+
+#' @S3method atypes repArchetypes
+#' @nord
+atypes.repArchetypes <- function(zs, ...) {
+ lapply(zs, atypes)
+}
+
+
+#' Number of archetypes getter.
+#'
+#' replaced by \code{\link{nparameters}}.
+#'
+#' @param zs An \code{archetypes}-related object.
+#' @param ... Further arguments.
+#' @return Number of archetypes.
+#' @export
+#' @rdname archetypes-deprecated
+ntypes <- function(zs, ...) {
+ .Deprecated('nparameters')
+ UseMethod('ntypes')
+}
+
+#' @S3method atypes archetypes
+#' @nord
+ntypes.archetypes <- function(zs, ...) {
+ return(zs$k)
+}
+
+#' @S3method ntypes stepArchetypes
+#' @nord
+ntypes.stepArchetypes <- function(zs, ...) {
+ return(sapply(zs, ntypes))
+}
+
+#' @S3method ntypes repArchetypes
+#' @nord
+ntypes.repArchetypes <- function(zs, ...) {
+ ntypes(zs[[1]])
+}
+
+
+
+#' Archetypes data approximation.
+#'
+#' replaced by \code{\link{fitted}}.
+#'
+#' @param zs An \code{archetypes}-related object.
+#' @param ... Further arguments.
+#' @return Approximated data matrix.
+#' @export
+#' @rdname archetypes-deprecated
+adata <- function(zs, ...) {
+ .Deprecated('fitted')
+ UseMethod('adata')
+}
+
+#' @S3method adata archetypes
+#' @nord
+adata.archetypes <- function(zs, ...) {
+ return(t(t(zs$archetypes) %*% t(zs$alphas)))
+}
+
+
+
+#' Alpha getter.
+#'
+#' replaced by \code{\link{coef}}.
+#'
+#' @param zs An \code{archetypes}-related object.
+#' @param ... Further arguments.
+#' @return Alpha matrix.
+#' @export
+#' @rdname archetypes-deprecated
+alphas <- function(zs, ...) {
+ .Deprecated('coef')
+ UseMethod('alphas')
+}
+
+#' @S3method alphas archetypes
+#' @nord
+alphas.archetypes <- function(zs, ...) {
+ return(zs$alphas)
+}
+
+
+
+#' Beta getter.
+#'
+#' replaced by \code{\link{coef}}.
+#'
+#' @param zs An \code{archetypes}-related object.
+#' @param ... Further arguments.
+#' @return Beta matrix.
+#' @export
+#' @rdname archetypes-deprecated
+betas <- function(zs, ...) {
+ .Deprecated('coef')
+ UseMethod('betas')
+}
+
+#' @S3method betas archetypes
+#' @nord
+betas.archetypes <- function(zs, ...) {
+ return(zs$betas)
+}
+
+
+
+#' Iteration getter.
+#'
+#' removed.
+#'
+#' @param zs An \code{archetypes}-related object.
+#' @param ... Further arguments.
+#' @return Number of iterations.
+#' @export
+#' @rdname archetypes-deprecated
+iters <- function(zs, ...) {
+ .Deprecated()
+ UseMethod('iters')
+}
+
+#' @S3method iters archetypes
+#' @nord
+iters.archetypes <- function(zs, ...) {
+ return(zs$iters)
+}
+
+
+
+#' Archetypes history getter.
+#'
+#' removed; see \code{\link{memento}}.
+#'
+#' @param zs An \code{archetypes}-related object.
+#' @param ... Further arguments.
+#' @return The \code{archetypes} object of the requested step.
+#' @export
+#' @rdname archetypes-deprecated
+ahistory <- function(zs, ...) {
+ .Deprecated('memento')
+ UseMethod('ahistory')
+}
+
+
+#' @S3method ahistory archetypes
+#' @nord
+ahistory.archetypes <- function(zs, step, ...) {
+ if ( is.null(zs$history) )
+ stop('No history available')
+
+ if ( step >= 0 )
+ s <- paste('s', step, sep='')
+ else
+ s <- paste('s', nhistory(zs) + step - 1, sep='')
+
+ return(zs$history[[s]][[1]])
+}
+
+
+
+#' Number of history steps getter.
+#'
+#' removed; see \code{\link{memento}}.
+#'
+#' @param zs An \code{archetypes}-related object.
+#' @param ... Further arguments.
+#' @return The number of history steps available.
+#' @export
+#' @rdname archetypes-deprecated
+nhistory <- function(zs, ...) {
+ .Deprecated('memento')
+ UseMethod('nhistory')
+}
+
+
+#' @S3method nhistory archetypes
+#' @nord
+nhistory.archetypes <- function(zs, ...) {
+ if ( is.null(zs$history) )
+ stop('No history available')
+
+ return(length(zs$history))
+}
+
Modified: pkg/R/archetypes-kit-blocks.R
===================================================================
--- pkg/R/archetypes-kit-blocks.R 2010-04-06 09:17:41 UTC (rev 39)
+++ pkg/R/archetypes-kit-blocks.R 2010-04-06 09:56:13 UTC (rev 40)
@@ -1,11 +1,12 @@
-### Scaling and rescaling functions:
+### Scaling and rescaling functions: #################################
#' Scaling block: standardize to mean 0 and standard deviation 1.
#' @param x Data matrix.
#' @return Standardized data matrix with some attribues.
-std.scalefn <- function(x) {
+#' @nord
+std.scalefn <- function(x, ...) {
m = rowMeans(x)
x = x - m
@@ -21,7 +22,8 @@
#' @param x Standardized data matrix.
#' @param zs Archetypes matrix
#' @return Rescaled archetypes.
-std.rescalefn <- function(x, zs) {
+#' @nord
+std.rescalefn <- function(x, zs, ...) {
m = attr(x, '.Meta')$mean
s = attr(x, '.Meta')$sd
@@ -37,7 +39,8 @@
#' Scaling block: no scaling.
#' @param x Data matrix.
#' @return Data matrix.
-no.scalefn <- function(x) {
+#' @nord
+no.scalefn <- function(x, ...) {
return(x)
}
@@ -45,27 +48,29 @@
#' @param x Data matrix.
#' @param zs Archetypes matrix.
#' @return Archetypes zs.
-no.rescalefn <- function(x, zs) {
+#' @nord
+no.rescalefn <- function(x, zs, ...) {
return(zs)
}
-### Dummy and undummy functions:
+### Dummy and undummy functions: #####################################
-#' Dummy block: generator for a dummy function which adds a row containing
-#' a huge value.
+#' Dummy block: generator for a dummy function which adds a row
+#' containing a huge value.
#' @param huge The value.
-#' @return A function which takes a data matrix and returns the data matrix
-#' with an additonal row containing \code{huge} values.
+#' @return A function which takes a data matrix and returns the
+#' data matrix with an additonal row containing \code{huge} values.
+#' @nord
make.dummyfn <- function(huge=200) {
- bp.dummyfn <- function(x) {
- y = rbind(x, rep(huge, ncol(x)))
-
+ bp.dummyfn <- function(x, ...) {
+ y = rbind(x, rep(huge, ncol(x)))
+
attr(y, '.Meta') = attr(x, '.Meta')
attr(y, '.Meta')$dummyrow = nrow(y)
-
+
return(y)
}
@@ -77,9 +82,10 @@
#' @param x Data matrix.
#' @param zs Archetypes matrix.
#' @return Archetypes zs.
-rm.undummyfn <- function(x, zs) {
+#' @nord
+rm.undummyfn <- function(x, zs, ...) {
dr = attr(x, '.Meta')$dummyrow
-
+
return(zs[-dr,])
}
@@ -87,7 +93,8 @@
#' Dummy block: no dummy row.
#' @param x Data matrix.
#' @return Data matrix x.
-no.dummyfn <- function(x) {
+#' @nord
+no.dummyfn <- function(x, ...) {
return(x)
}
@@ -95,19 +102,22 @@
#' @param x Data matrix.
#' @param zs Archetypes matrix.
#' @return Archetypes zs.
-no.undummyfn <- function(x, zs) {
+#' @nord
+no.undummyfn <- function(x, zs, ...) {
return(zs)
}
-### `From X and alpha to archetypes` functions:
+### `From X and alpha to archetypes` functions: ######################
+
#' X to alpha block: QR approach.
#' @param alphas The coefficients.
#' @param x Data matrix.
#' @return The solved linear system.
-qrsolve.zalphasfn <- function(alphas, x) {
+#' @nord
+qrsolve.zalphasfn <- function(alphas, x, ...) {
return(t(qr.solve(alphas %*% t(alphas)) %*% alphas %*% t(x)))
}
@@ -117,9 +127,10 @@
#' @param alphas The coefficients.
#' @param x Data matrix.
#' @return The solved linear system.
-ginv.zalphasfn <- function(alphas, x) {
+#' @nord
+ginv.zalphasfn <- function(alphas, x, ...) {
require(MASS)
-
+
return(t(ginv(alphas %*% t(alphas)) %*% alphas %*% t(x)))
}
@@ -129,9 +140,10 @@
#' @param alphas The coefficients.
#' @param x Data matrix.
#' @return The solved linear system.
-opt.zalphasfn <- function(alphas, x) {
+#' @nord
+opt.zalphasfn <- function(alphas, x, ...) {
z <- rnorm(nrow(x)*nrow(alphas))
-
+
fun <- function(z){
z <- matrix(z, ncol=nrow(alphas))
sum( (x - z %*% alphas)^2)
@@ -145,18 +157,20 @@
-### Alpha calculation functions:
+### Alpha calculation functions: #####################################
+
#' Alpha block: plain nnls.
#' @param coefs The coefficients alpha.
#' @param C The archetypes matrix.
#' @param d The data matrix.
#' @return Recalculated alpha.
-nnls.alphasfn <- function(coefs, C, d) {
+#' @nord
+nnls.alphasfn <- function(coefs, C, d, ...) {
require(nnls)
-
+
n = ncol(d)
-
+
for ( j in 1:n )
coefs[,j] = coef(nnls(C, d[,j]))
@@ -168,15 +182,16 @@
#' @param C The archetypes matrix.
#' @param d The data matrix.
#' @return Recalculated alpha.
-snnls.alphasfn <- function(coefs, C, d) {
+#' @nord
+snnls.alphasfn <- function(coefs, C, d, ...) {
require(nnls)
n = ncol(d)
nc = ncol(C)
nr = nrow(C)
-
+
s = svd(C, nv=nc)
yint = t(s$u) %*% d
@@ -188,7 +203,7 @@
-### Beta calculation functions:
+### Beta calculation functions: ######################################
#' Beta block: plain nnls.
@@ -196,6 +211,7 @@
#' @param C The data matrix.
#' @param d The archetypes matrix.
#' @return Recalculated beta.
+#' @nord
nnls.betasfn <- nnls.alphasfn
@@ -205,17 +221,19 @@
#' @param C The data matrix.
#' @param d The archetypes matrix.
#' @return Recalculated beta.
+#' @nord
snnls.betasfn <- snnls.alphasfn
-### Norm functions:
+### Norm functions: ##################################################
#' Norm block: standard matrix norm (spectral norm).
#' @param m Matrix.
#' @return The norm.
-norm2.normfn <- function(m) {
+#' @nord
+norm2.normfn <- function(m, ...) {
return(max(svd(m)$d))
}
@@ -223,30 +241,33 @@
#' Norm block: euclidian norm.
#' @param m Matrix.
#' @return The norm.
-euc.normfn <- function(m) {
+#' @nord
+euc.normfn <- function(m, ...) {
return(sum(apply(m, 2, function(x){sqrt(sum(x^2))})))
}
-
-### Archetypes initialization functions:
+### Archetypes initialization functions: #############################
+
+
#' Init block: generator for random initializtion.
#' @param k The proportion of beta for each archetype.
#' @return A function which returns a list with alpha and beta.
+#' @nord
make.random.initfn <- function(k) {
- bp.initfn <- function(x, p) {
-
- n = ncol(x)
- b = matrix(0, nrow=n, ncol=p)
+ bp.initfn <- function(x, p, ...) {
+ n <- ncol(x)
+ b <- matrix(0, nrow=n, ncol=p)
+
for ( i in 1:p )
- b[sample(n, k, replace=FALSE),i] = 1 / k
-
- a = matrix(1, nrow=p, ncol=n) / p
-
- return(list(betas=b, alphas=a))
+ b[sample(n, k, replace=FALSE),i] <- 1 / k
+
+ a <- matrix(1, nrow = p, ncol = n) / p
+
+ return(list(betas = b, alphas = a))
}
return(bp.initfn)
@@ -255,16 +276,17 @@
#' Init block: generator for fix initializtion.
#' @param indizes The indizies of data points to use as archetypes.
#' @return A function which returns a list with alpha and beta.
+#' @nord
make.fix.initfn <- function(indizes) {
- fix.initfn <- function(x, p) {
- n = ncol(x)
-
- b = matrix(0, nrow = n, ncol = p)
- b[indizes,] = diag(p)
+ fix.initfn <- function(x, p, ...) {
+ n <- ncol(x)
- a = matrix(1, nrow = p, ncol = n) / p
-
+ b <- matrix(0, nrow = n, ncol = p)
+ b[indizes, ] <- diag(p)
+
+ a <- matrix(1, nrow = p, ncol = n) / p
+
return(list(betas = b, alphas = a))
}
@@ -273,31 +295,147 @@
-### Archetypes family:
+### Weight functions: ################################################
+
+#' Weight function: move data closer to global center
+#' @param data A numeric \eqn{m \times n} data matrix.
+#' @param weights Vector of data weights within \eqn{[0, 1]}.
+#' @return Weighted data matrix.
+#' @nord
+center.weightfn <- function(data, weights, ...) {
+ if ( is.null(weights) )
+ return(data)
+
+ weights <- as.numeric(1 - weights)
+
+ dr <- attr(data, '.Meta')$dummyrow
+
+ if ( is.null(dr) ) {
+ center <- rowMeans(data)
+ data <- data + t(weights * t(center - data))
+ }
+ else {
+ center <- rowMeans(data[-dr, ])
+ data[-dr, ] <- data[-dr, ] + t(weights * t(center - data[-dr, ]))
+ }
+
+ data
+}
+
+#' Global weight function: move data closer to global center
+#' @param data A numeric \eqn{m \times n} data matrix.
+#' @param weights Vector or matrix of data weights within \eqn{[0, 1]}.
+#' @return Weighted data matrix.
+#' @nord
+center.globweightfn <- function(data, weights, ...) {
+ if ( is.null(weights) )
+ return(data)
+
+ if ( is.vector(weights) )
+ weights <- diag(weights)
+
+ dr <- attr(data, '.Meta')$dummyrow
+
+ if ( is.null(dr) ) {
+ data <- data %*% weights
+ }
+ else {
+ data[-dr, ] <- data[-dr, ] %*% weights
+ }
+
+ data
+}
+
+
+
+### Reweights functions: #############################################
+
+
+#' Reweights function: calculate Bisquare reweights.
+#' @param resid A numeric \eqn{m \times n} data matrix.
+#' @param reweights Vector of data reweights within \eqn{[0, 1]}.
+#' @return Reweights vector.
+#' @nord
+bisquare0.reweightsfn <- function(resid, reweights, ...) {
+ resid <- apply(resid, 2, function(x) sum(abs(x)))
+ resid0 <- resid < sqrt(.Machine$double.eps)
+
+ s <- 6 * median(resid[!resid0])
+ v <- resid / s
+
+ ifelse(v < 1, (1 - v^2)^2, 0)
+}
+
+
+
+#' Reweights function: calculate binary Bisquare reweights.
+#' @param resid A numeric \eqn{m \times n} data matrix.
+#' @param reweights Vector of data reweights within \eqn{[0, 1]}.
+#' @param threshold Threshold for binarization.
+#' @return Reweights vector.
+#' @nord
+binary.bisquare0.reweightsfn <- function(resid, reweights,
+ threshold = 0.1, ...) {
+ rw <- bisquare0.reweightsfn(resid, reweights, ...)
+ ifelse(rw < threshold, 0, 1)
+}
+
+
+
+### Archetypes family: ###############################################
+
+
#' Archetypes family constructor.
#'
-#' This function returns a problem solving brick for each of the different
-#' conceptual parts of the algorithm. Currently, only the 'original' family
-#' is supported.
+#' This function returns a problem solving block for each of the
+#' different conceptual parts of the algorithm.
#'
-#' @param which The kind of archetypes family; currently ignored.
+#' @param which The kind of archetypes family.
+#' @param ... Exchange predefined family blocks with self-defined
+#' functions.
#' @return A list containing a function for each of the different parts.
#' @seealso \code{\link{archetypes}}
#' @export
-archetypesFamily <- function(which=c('default', 'ginv')) {
- fam <- list(normfn=norm2.normfn,
- scalefn=std.scalefn,
- rescalefn=std.rescalefn,
- dummyfn=make.dummyfn(200),
- undummyfn=rm.undummyfn,
- initfn=make.random.initfn(1),
- alphasfn=nnls.alphasfn,
- betasfn=nnls.betasfn)
+archetypesFamily <- function(which = c('original', 'weighted', 'robust'), ...) {
- fam$zalphasfn <- switch(which[1],
- 'default' = qrsolve.zalphasfn,
- 'ginv' = ginv.zalphasfn)
+ which <- match.arg(which)
+ blocks <- list(...)
- return(fam)
+ family <- do.call(sprintf('.%s.archetypesFamily', which), list())
+ family$which <- which
+ family$which.exchanged <- NULL
+
+ if ( length(blocks) > 0 ) {
+ family$which <- sprintf('%s*', family$which)
+ family$which.exchanged <- names(blocks)
+
+ for ( n in names(blocks) )
+ family[[n]] <- blocks[[n]]
+ }
+
+
+ family
}
+
+
+
+#' Original family constructor helper.
+#' @return A list of blocks.
+#' @nord
+.original.archetypesFamily <- function() {
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/archetypes -r 40
More information about the Archetypes-commits
mailing list