[Archetypes-commits] r35 - in branches/pkg-robust: . R demo
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Mar 31 17:58:20 CEST 2010
Author: manuel
Date: 2010-03-31 17:58:20 +0200 (Wed, 31 Mar 2010)
New Revision: 35
Added:
branches/pkg-robust/NEWS
branches/pkg-robust/R/archetypes-xyplot.R
branches/pkg-robust/demo/
branches/pkg-robust/demo/00Index
branches/pkg-robust/demo/robust-toy.R
Removed:
branches/pkg-robust/R/archetypes-diagplots.R
branches/pkg-robust/R/archetypes-plot.R
Modified:
branches/pkg-robust/DESCRIPTION
branches/pkg-robust/R/archetypes-barplot.R
branches/pkg-robust/R/archetypes-class-bc.R
branches/pkg-robust/R/archetypes-class.R
branches/pkg-robust/R/archetypes-kit-blocks.R
branches/pkg-robust/R/archetypes-kit.R
branches/pkg-robust/R/archetypes-movie.R
branches/pkg-robust/R/archetypes-panorama.R
branches/pkg-robust/R/archetypes-pcplot.R
branches/pkg-robust/R/archetypes-robust.R
branches/pkg-robust/R/archetypes-step.R
branches/pkg-robust/R/archetypes-weighted.R
branches/pkg-robust/R/pcplot.R
branches/pkg-robust/R/skeletonplot.R
Log:
Modified: branches/pkg-robust/DESCRIPTION
===================================================================
--- branches/pkg-robust/DESCRIPTION 2010-03-26 08:13:37 UTC (rev 34)
+++ branches/pkg-robust/DESCRIPTION 2010-03-31 15:58:20 UTC (rev 35)
@@ -10,9 +10,5 @@
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
Added: branches/pkg-robust/NEWS
===================================================================
--- branches/pkg-robust/NEWS (rev 0)
+++ branches/pkg-robust/NEWS 2010-03-31 15:58:20 UTC (rev 35)
@@ -0,0 +1,19 @@
+
+Changes in archetypes version 2.0
+
+ o Cleaned up interface.
+
+ Rename to common names:
+ atypes -> parameters
+ adata -> fitted
+ alphas -> coef
+ betas -> coef
+ plot -> xyplot
+ ntypes <- nparameters
+
+ Remove unneeded:
+ iters -> NA
+
+ o added weighted and robust archetypes.
+
+
Property changes on: branches/pkg-robust/NEWS
___________________________________________________________________
Name: svn:keywords
+ Date Revision Author URL Id
Name: svn:eol-style
+ native
Modified: branches/pkg-robust/R/archetypes-barplot.R
===================================================================
--- branches/pkg-robust/R/archetypes-barplot.R 2010-03-26 08:13:37 UTC (rev 34)
+++ branches/pkg-robust/R/archetypes-barplot.R 2010-03-31 15:58:20 UTC (rev 35)
@@ -18,7 +18,9 @@
which = c('below', 'beside'),
which.beside = c('atypes', 'variables'),
which.below = c('compressed', 'default'),
- percentiles = FALSE, ...) {
+ percentiles = FALSE,
+ below.compressed.height = 0.1,
+ below.compressed.srt = 0, ...) {
### Helpers:
.beside.atypes <- function() {
@@ -43,17 +45,20 @@
.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)
}
@@ -74,7 +79,7 @@
else
which.arg <- match.arg(which.below)
- atypes <- atypes(height)
+ atypes <- parameters(height)
rownames(atypes) <- sprintf('Archetype %s',
seq(length = nrow(atypes)))
Modified: branches/pkg-robust/R/archetypes-class-bc.R
===================================================================
--- branches/pkg-robust/R/archetypes-class-bc.R 2010-03-26 08:13:37 UTC (rev 34)
+++ branches/pkg-robust/R/archetypes-class-bc.R 2010-03-31 15:58:20 UTC (rev 35)
@@ -1,64 +1,62 @@
-.v2 <- function(old, new) {
- warning(sprintf('Function %s is deprecated; please use %s instead.',
- sQuote(old), sQuote(new)),
- call. = FALSE)
-}
+
#' Archetypes getter.
#' @param zs An \code{archetypes}-related object.
#' @param ... Further arguments.
#' @return Archetypes matrix.
#' @export
+#' @rdname archetypes-deprecated
atypes <- function(zs, ...) {
+ .Deprecated('parameters')
UseMethod('atypes')
}
-#' Archetypes getter.
-#' @param zs An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return Archetypes matrix.
-#' @method atypes archetypes
#' @S3method atypes archetypes
+#' @nord
atypes.archetypes <- function(zs, ...) {
- .v2('atypes', 'parameters')
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.
#' @param zs An \code{archetypes}-related object.
#' @param ... Further arguments.
-#' @return Number of archetypes.
+#' @return Archetypes matrix.
#' @export
+#' @rdname archetypes-deprecated
ntypes <- function(zs, ...) {
+ .Deprecated('nparameters')
UseMethod('ntypes')
}
-#' @S3method ntypes archetypes
+#' @S3method atypes archetypes
+#' @nord
ntypes.archetypes <- function(zs, ...) {
return(zs$k)
}
-
-
-#' Residual sum of squares getter.
-#' @param zs An \code{archetypes}-related object.
-#' @param ... Further arguments.
-#' @return Residual sum of squares.
-#' @export
-rss <- function(zs, ...) {
- UseMethod('rss')
+#' @S3method ntypes stepArchetypes
+#' @nord
+ntypes.stepArchetypes <- function(zs, ...) {
+ return(sapply(zs, ntypes))
}
-#' Residual sum of squares getter.
-#' @param zs An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return Residual sum of squares.
-#' @method rss archetypes
-#' @S3method rss archetypes
-rss.archetypes <- function(zs, ...) {
- return(zs$rss)
+#' @S3method ntypes repArchetypes
+#' @nord
+ntypes.repArchetypes <- function(zs, ...) {
+ ntypes(object[[1]])
}
@@ -68,18 +66,15 @@
#' @param ... Further arguments.
#' @return Approximated data matrix.
#' @export
+#' @rdname archetypes-deprecated
adata <- function(zs, ...) {
+ .Deprecated('fitted')
UseMethod('adata')
}
-#' Archetypes data approximation.
-#' @param zs An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return Approximated data matrix.
-#' @method adata archetypes
#' @S3method adata archetypes
+#' @nord
adata.archetypes <- function(zs, ...) {
- .v2('adata', 'fitted')
return(t(t(zs$archetypes) %*% t(zs$alphas)))
}
@@ -90,18 +85,15 @@
#' @param ... Further arguments.
#' @return Alpha matrix.
#' @export
+#' @rdname archetypes-deprecated
alphas <- function(zs, ...) {
+ .Deprecated('coef')
UseMethod('alphas')
}
-#' Alpha getter.
-#' @param zs An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return Alpha matrix.
-#' @method alphas archetypes
#' @S3method alphas archetypes
+#' @nord
alphas.archetypes <- function(zs, ...) {
- .v2('alphas', 'coef')
return(zs$alphas)
}
@@ -112,18 +104,15 @@
#' @param ... Further arguments.
#' @return Beta matrix.
#' @export
+#' @rdname archetypes-deprecated
betas <- function(zs, ...) {
+ .Deprecated('coef')
UseMethod('betas')
}
-#' Beta getter.
-#' @param zs An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return Beta matrix.
-#' @method betas archetypes
#' @S3method betas archetypes
+#' @nord
betas.archetypes <- function(zs, ...) {
- .v2('betas', 'coef')
return(zs$betas)
}
@@ -134,16 +123,14 @@
#' @param ... Further arguments.
#' @return Number of iterations.
#' @export
+#' @rdname archetypes-deprecated
iters <- function(zs, ...) {
+ .Deprecated()
UseMethod('iters')
}
-#' Iteration getter.
-#' @param zs An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return Number of iterations.
-#' @method iters archetypes
#' @S3method iters archetypes
+#' @nord
iters.archetypes <- function(zs, ...) {
return(zs$iters)
}
@@ -202,13 +189,3 @@
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)
-}
Modified: branches/pkg-robust/R/archetypes-class.R
===================================================================
--- branches/pkg-robust/R/archetypes-class.R 2010-03-26 08:13:37 UTC (rev 34)
+++ branches/pkg-robust/R/archetypes-class.R 2010-03-31 15:58:20 UTC (rev 35)
@@ -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;
@@ -21,10 +21,8 @@
#' @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
+#' @seealso \code{\link{archetypes}}
+#' @rdname 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,
@@ -59,6 +57,7 @@
#' @return Undefined.
#' @method print archetypes
#' @S3method print archetypes
+#' @nord
print.archetypes <- function(x, full = TRUE, ...) {
if ( full ) {
cat('Archetypes object\n\n')
@@ -74,9 +73,10 @@
#' Return fitted data, i.e. archetypes data approximation.
#' @param object An \code{archetypes}-related object.
#' @param ... Ignored.
-#' @return Approximated data matrix.
+#' @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))
}
@@ -86,14 +86,16 @@
#' Return fitted archetypes.
#' @param object An \code{archetypes} object.
#' @param ... Ignored.
-#' @return Archetypes matrix.
+#' @return Matrix with \eqn{k} archetypes.
#' @method parameters archetypes
#' @S3method parameters archetypes
+#' @rdname archetypes-class
parameters.archetypes <- function(object, ...) {
object$archetypes
}
#' @importFrom modeltools parameters
+#' @nord
setMethod('parameters', 'archetypes', parameters.archetypes)
@@ -105,6 +107,7 @@
#' @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]]
@@ -114,9 +117,10 @@
#' Return residuals.
#' @param object An \code{archetypes} object.
#' @param ... Ignored.
-#' @return Residuals.
+#' @return Matrix with residuals.
#' @method residuals archetypes
#' @S3method residuals archetypes
+#' @rdname archetypes-class
residuals.archetypes <- function(object, ...) {
object$residuals
}
@@ -128,6 +132,7 @@
#' @param ... Ignored.
#' @return Residual sum of squares.
#' @export
+#' @nord
rss <- function(object, ...) {
UseMethod('rss')
}
@@ -139,6 +144,7 @@
#' @return Residual sum of squares.
#' @method rss archetypes
#' @S3method rss archetypes
+#' @rdname archetypes-class
rss.archetypes <- function(object, type = c('scaled', 'single', 'global')) {
type <- match.arg(type)
resid <- residuals(object)
@@ -158,6 +164,7 @@
#' @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]]
@@ -165,6 +172,19 @@
+#' Kappa getter.
+#' @param z An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return A vector of kappas.
+#' @method kappa archetypes
+#' @S3method kappa archetypes
+#' @rdname archetypes-class
+kappa.archetypes <- function(z, ...) {
+ return(z$kappas)
+}
+
+
+
#' Predict coefficients or data based on archetypes.
#' @param object An \code{archetypes} object.
#' @param type Predict alphas or data.
@@ -172,6 +192,7 @@
#' @return Prediction.
#' @method predict archetypes
#' @S3method predict archetypes
+#' @nord
predict.archetypes <- function(object, newdata = NULL,
type = c('alphas', 'data'), ...) {
type <- match.arg(type)
@@ -190,3 +211,25 @@
+#' Number of parameters.
+#' @param object An \code{archetypes}-related object.
+#' @param ... Further arguments.
+#' @return Number of archetypes.
+#' @export
+#' @nord
+nparameters <- function(object, ...) {
+ UseMethod('nparameters')
+}
+
+
+
+#' Number of archetypes
+#' @param object An \code{archetypes}-related object.
+#' @param ... Further arguments.
+#' @return Number of archetypes.
+#' @method nparameters archetypes
+#' @S3method nparameters archetypes
+#' @rdname archetypes-class
+nparameters.archetypes <- function(object, ...) {
+ return(object$k)
+}
Deleted: branches/pkg-robust/R/archetypes-diagplots.R
===================================================================
--- branches/pkg-robust/R/archetypes-diagplots.R 2010-03-26 08:13:37 UTC (rev 34)
+++ branches/pkg-robust/R/archetypes-diagplots.R 2010-03-31 15:58:20 UTC (rev 35)
@@ -1,195 +0,0 @@
-
-residuals.diagplot <- function(object, ref.order = 1, ...) {
- y <- residuals(object)
- x <- seq(length = nrow(y))
-
- m <- ncol(y)
-
- ylim <- range(y)
- ylab <- colnames(y)
-
- if ( is.null(ref.order) ) {
- ref.order <- 0
- ix <- seq(length = nrow(y))
- }
- else {
- ix <- order(y[, ref.order])
- }
-
- layout(matrix(seq(length = m), nrow = m, ncol = 1))
- for ( i in seq(length = m) ) {
- plot(x, y[ix, i], ylim = ylim,
- ylab = sprintf('Residuals %s', ylab[i]),
- xlab = sprintf('Index%s', ifelse(i == ref.order, ' (reference order)', '')),
- ...)
- abline(h = 0, lty = 2, col = gray(0.7), ...)
- }
-
-
- invisible(list(x = x, y = y))
-}
-
-
-
-rss.diagplot <- function(object, ...) {
- UseMethod('rss.diagplot')
-}
-
-rss.diagplot.archetypes <- function(object, sort = FALSE, ...) {
- y <- rss(object, type = 'single')
- x <- seq(length = length(y))
-
- if ( sort )
- xy <- sort(y)
-
- plot(x, y, xlab = 'Index', ylab = 'RSS', ...)
- abline(h = 0, lty = 2, col = gray(0.7), ...)
-
-
- invisible(list(x = x, y = y))
-}
-
-rss.diagplot.repArchetypes <- function(object, ...) {
- y <- lapply(object, rss, type = 'single')
- x <- seq(length = length(y[[1]]))
-
- ylim <- range(sapply(y, range))
-
- plot(x, y[[1]], xlab = 'Index', ylab = 'RSS',
- ylim = ylim, type = 'n', ...)
- for ( i in seq(along = y) )
- lines(x, y[[i]], col = i, ...)
-}
-
-
-
-weights.diagplot <- function(object, weights.type, ...) {
- y <- weights(object, weights.type)
- x <- seq(length = length(y))
-
- ylab <- sprintf('%s%s', toupper(substring(weights.type, 1, 1)),
- substring(weights.type, 2))
-
- plot(x, y, ylim = c(1, 0), xlab = 'Index', ylab = ylab, ...)
-}
-
-
-
-reweights.diagplot <- function(object, col = 1, pch = 1, highlight = NULL,
- highlight.col = (seq(length(highlight)) + 1),
- highlight.pch = 13, ...) {
-
- y <- rev(lapply(object$history, function(x) x[[1]]$reweights))
- x <- seq(along = y[[1]])
-
- col <- rep(col, length = length(x))
- col[highlight] <- highlight.col
-
- pch <- rep(pch, length = length(x))
- pch[highlight] <- highlight.pch
-
- n <- sqrt(length(y))
-
- par(mfrow = c(ceiling(n), ceiling(n)), mar = c(0, 0, 0, 0))
- for ( i in seq(along = y) )
- plot(x, y[[i]], type = 'p', col = col, pch = pch, ylim = c(0, 1),
- xlab = 'Index', ylab = 'Reweights', ...)
-}
-
-
-
-reweights.curve.diagplot <- function(object, i, lty = 1,
- col = (seq(length(i)) + 1), ...) {
- y <- sapply(object$history, function(x) x[[1]]$reweights[i])
- y <- apply(y, 1, rev)
-
- matplot(y, type = 'l', lty = lty, col = col, ylab = 'Reweights',
- xlab = 'Iterations', ylim = c(0, 1), ...)
-}
-
-
-
-reweights.liftoff.diagplot <- function(object, ...) {
-
- y <- sapply(object$history, function(x) x[[1]]$reweights)
- y <- rev(colSums(y != 0))
-
- barplot(y, xlab = 'Iterations', ylab = 'Reweights > 0', ...)
-}
-
-
-
-reweights.rss.diagplot <- function(object, ...) {
- y1 <- sapply(object$history, function(x) x[[1]]$reweights)
- y1 <- rev(colSums(y1))
-
- y2 <- rev(sapply(object$history, function(x) x[[1]]$rss))
-
- x <- seq(along = y1)
-
- par(mfrow = c(2, 1))
- plot(x, y1, type = 'l', xlab = 'Iterations', ylab = 'Reweights', ...)
- plot(x, y2, type = 'l', xlab = 'Iterations', ylab = 'RSS', ...)
-}
-
-
-archetypes.view.diagplot <- function(object, data, ref.order = NULL,
- distfn = distEuclidean, ...) {
-
- d <- distfn(data, parameters(object))
- x <- seq(length = nrow(d))
-
- if ( is.null(ref.order) )
- ix <- x
- else
- ix <- order(d[, ref.order])
-
- ylim <- c(0, max(d))
-
- par(mfrow = c(ncol(d), 1))
- for ( i in seq(length = ncol(d)) )
- plot(x, d[ix, i], xlab = sprintf('Archetype %s', i),
- ylab = 'Distance', ylim = ylim, ...)
-
- invisible(d)
-}
-
-
-archetypes.distance.diagplot <- function(object, data,
- distfn = distEuclidean, ...) {
-
- opar <- par()
-
- d <- distfn(data, parameters(object))
- x <- seq(length = nrow(d))
-
- ylim <- c(0, max(d))
-
- globals <- array(dim = c(dim(d), 2))
-
- par(mfrow = c(ncol(d) + 1, 1), xpd = NA)
- for ( i in seq(length = ncol(d)) ) {
- ix <- order(d[, i])
-
- plot(x, d[ix, i], xlab = '', ylab = 'Distance', ylim = ylim,
- type = 'b', axes = FALSE, ...)
- axis(2)
- box()
-
- globals[, i, 1] <- grconvertX(rank(d[, i]), to = 'device')
- globals[, i, 2] <- grconvertY(d[, i], to = 'device')
- }
- axis(1)
- mtext('Data index', side = 1, line = 3, cex = par('cex'))
-
- for ( i in seq(length = nrow(globals)) ) {
- px <- grconvertX(globals[i, , 1], from = 'device')
- py <- grconvertY(globals[i, , 2], from = 'device')
-
- lines(px, py, col = gray(0.7))
- }
-
- par(opar)
-
- invisible(d)
-}
Modified: branches/pkg-robust/R/archetypes-kit-blocks.R
===================================================================
--- branches/pkg-robust/R/archetypes-kit-blocks.R 2010-03-26 08:13:37 UTC (rev 34)
+++ branches/pkg-robust/R/archetypes-kit-blocks.R 2010-03-31 15:58:20 UTC (rev 35)
@@ -1,10 +1,11 @@
-### 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.
+#' @nord
std.scalefn <- function(x, ...) {
m = rowMeans(x)
x = x - m
@@ -21,6 +22,7 @@
#' @param x Standardized data matrix.
#' @param zs Archetypes matrix
#' @return Rescaled archetypes.
+#' @nord
std.rescalefn <- function(x, zs, ...) {
m = attr(x, '.Meta')$mean
@@ -37,6 +39,7 @@
#' Scaling block: no scaling.
#' @param x Data matrix.
#' @return Data matrix.
+#' @nord
no.scalefn <- function(x, ...) {
return(x)
}
@@ -45,19 +48,21 @@
#' @param x Data matrix.
#' @param zs Archetypes matrix.
#' @return Archetypes 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, ...) {
@@ -77,6 +82,7 @@
#' @param x Data matrix.
#' @param zs Archetypes matrix.
#' @return Archetypes zs.
+#' @nord
rm.undummyfn <- function(x, zs, ...) {
dr = attr(x, '.Meta')$dummyrow
@@ -87,6 +93,7 @@
#' Dummy block: no dummy row.
#' @param x Data matrix.
#' @return Data matrix x.
+#' @nord
no.dummyfn <- function(x, ...) {
return(x)
}
@@ -95,18 +102,21 @@
#' @param x Data matrix.
#' @param zs Archetypes matrix.
#' @return Archetypes 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.
+#' @nord
qrsolve.zalphasfn <- function(alphas, x, ...) {
return(t(qr.solve(alphas %*% t(alphas)) %*% alphas %*% t(x)))
}
@@ -117,6 +127,7 @@
#' @param alphas The coefficients.
#' @param x Data matrix.
#' @return The solved linear system.
+#' @nord
ginv.zalphasfn <- function(alphas, x, ...) {
require(MASS)
@@ -129,6 +140,7 @@
#' @param alphas The coefficients.
#' @param x Data matrix.
#' @return The solved linear system.
+#' @nord
opt.zalphasfn <- function(alphas, x, ...) {
z <- rnorm(nrow(x)*nrow(alphas))
@@ -145,13 +157,15 @@
-### 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.
+#' @nord
nnls.alphasfn <- function(coefs, C, d, ...) {
require(nnls)
@@ -168,6 +182,7 @@
#' @param C The archetypes matrix.
#' @param d The data matrix.
#' @return Recalculated alpha.
+#' @nord
snnls.alphasfn <- function(coefs, C, d, ...) {
require(nnls)
@@ -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,16 +221,18 @@
#' @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.
+#' @nord
norm2.normfn <- function(m, ...) {
return(max(svd(m)$d))
}
@@ -223,17 +241,20 @@
#' Norm block: euclidian norm.
#' @param m Matrix.
#' @return The norm.
+#' @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, ...) {
@@ -255,6 +276,7 @@
#' 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, ...) {
@@ -273,12 +295,14 @@
-### Weighting functions:
+### Weight functions: ################################################
-#' Weighting function: move data closer to global center
+
+#' 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)
@@ -301,8 +325,14 @@
-### Reweighting functions:
+### 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)
@@ -314,65 +344,32 @@
}
+
+#' 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,
- cutpoint = 0.1, ...) {
+ threshold = 0.1, ...) {
rw <- bisquare0.reweightsfn(resid, reweights, ...)
ifelse(rw < cutpoint, 0, 1)
}
-bisquare.reweightsfn <- function(resid, reweights, ...) {
- resid.abs <- apply(resid, 2, function(x) sum(abs(x)))
- mar <- mad(resid.abs, constant = 1) / 0.6754
- k <- 4.685 * mar
+### Archetypes family: ###############################################
- resid.euc <- apply(resid / k, 2, function(x) sum(x^2))
- ifelse(resid.abs <= k, (1 - resid.euc)^2, 0)
-}
-
-tricube.reweightsfn <- function(resid, reweights, ...) {
- resid <- apply(resid, 2, function(x) sum(abs(x)))
- ifelse(resid < 1, (1 - resid^3)^3, 0)
-}
-
-leastwise.tricube.reweightsfn <- function(resid, reweights,
- nperc = 0.8, minrw = 0.3, ...) {
-
- resid <- apply(resid, 2, function(x) sum(abs(x)))
- resid0 <- resid < sqrt(.Machine$double.eps)
- resido <- order(resid)
-
- n0 <- ceiling(sum(!resid0) * nperc)
-
- ix <- resido[!resid0][seq(length = n0)]
-
- rw <- ifelse(resid < 1, (1 - resid^3)^3, 0)
- rw[ix] <- ifelse(rw[ix] < minrw, minrw, rw[ix])
-
- rw
-}
-
-
-binary.tricube.reweightsfn <- function(resid, reweights,
- cutpoint = 0.1, ...) {
- rw <- tricube.reweightsfn(resid, reweights, ...)
- ifelse(rw < cutpoint, 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.
-#' @param ... Exchange blocks predefined by the kind of 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
@@ -397,6 +394,11 @@
family
}
+
+
+#' Original family constructor helper.
+#' @return A list of blocks.
+#' @nord
.original.archetypesFamily <- function() {
list(normfn = norm2.normfn,
scalefn = std.scalefn,
@@ -408,7 +410,7 @@
betasfn = nnls.betasfn,
zalphasfn = qrsolve.zalphasfn,
weightfn = function(x, weights) x,
- reweightsfn = function(x, weights) NULL,
+ reweightsfn = function(x, weights) weights,
class = NULL)
}
Modified: branches/pkg-robust/R/archetypes-kit.R
===================================================================
--- branches/pkg-robust/R/archetypes-kit.R 2010-03-26 08:13:37 UTC (rev 34)
+++ branches/pkg-robust/R/archetypes-kit.R 2010-03-31 15:58:20 UTC (rev 35)
@@ -7,7 +7,7 @@
#' Perform archetypal analysis on a data matrix.
#' @param data A numeric \eqn{n \times m} data matrix.
#' @param k The number of archetypes.
-#' @param weights Data weights vector.
+#' @param weights Data weights matrix.
#' @param maxIterations The maximum number of iterations.
#' @param minImprovement The minimal value of improvement between two
#' iterations.
@@ -30,7 +30,7 @@
#' @note Please see the vignette for a detailed explanation!
archetypes <- function(data, k, weights = NULL, maxIterations = 100,
minImprovement = sqrt(.Machine$double.eps),
- maxKappa = 1000, verbose = TRUE, saveHistory = TRUE,
+ maxKappa = 1000, verbose = FALSE, saveHistory = TRUE,
family = archetypesFamily('original'), ...) {
### Helpers:
@@ -43,7 +43,7 @@
list(archetypes = as.archetypes(t(family$rescalefn(x, family$undummyfn(x, zs))),
k, alphas = t(alphas), betas = t(betas), rss = rss, kappas = kappas,
zas = t(family$rescalefn(x, family$undummyfn(x, zas))),
- residuals = resid, reweights = reweights,
+ residuals = resid, reweights = reweights, weights = weights,
family = list(class = family$class)))
}
@@ -155,17 +155,13 @@
' > maxKappa', sep = '')
- ### Rescale archetypes, etc.:
- if ( !is.null(weights) || !is.null(reweights) ) {
- alphas <- family$alphasfn(alphas, zs, x1)
- betas <- family$betasfn(betas, x1, zs)
- }
+ ### Rescale and recalculate for original data:
+ alphas <- family$alphasfn(alphas, zs, x1)
+ betas <- family$betasfn(betas, x1, zs)
- zs <- family$undummyfn(x, zs)
- zs <- family$rescalefn(x, zs)
+ zs <- family$undummyfn(x1, zs)
+ zs <- family$rescalefn(x1, zs)
-
- ### Recalculate residuals, etc. for original data:
resid <- zs %*% alphas - t(data)
Modified: branches/pkg-robust/R/archetypes-movie.R
===================================================================
--- branches/pkg-robust/R/archetypes-movie.R 2010-03-26 08:13:37 UTC (rev 34)
+++ branches/pkg-robust/R/archetypes-movie.R 2010-03-31 15:58:20 UTC (rev 35)
@@ -1,6 +1,6 @@
-#' Archetypes plot movie.
+#' Archetypes movies.
#' @param zs An \code{\link{archetypes}} object.
#' @param data The data matrix.
#' @param show Show archetypes or approximated data.
@@ -10,9 +10,6 @@
#' iteration after the plot call.
#' @param ... Passed to underlying plot functions.
#' @return Undefined.
-#' @usage
-#' movieplot(zs, data, show=c('atypes', 'adata'),
-#' ssleep=0, bsleep=0, postfn=function(iter){}, ...)
#' @aliases movieplot
#' @export
movieplot <- function(zs, data, show=c('atypes', 'adata', 'rwdata'),
@@ -34,7 +31,7 @@
switch(show,
atypes = {
- plot(a, data, ...)
+ xyplot(a, data, ...)
},
adata = {
@@ -70,6 +67,7 @@
#' @param ... Passed to underlying plot functions.
#' @return Undefined.
#' @export
+#' @rdname movieplot
movieplot2 <- function(zs, data, show='atypes',
ssleep=0, bsleep=0,
zas.col=2, zas.pch=13,
@@ -89,14 +87,14 @@
a0 <- ahistory(zs, step=(i-1))
a <- ahistory(zs, step=i)
- plot(a0, data, atypes.col=old.col, ...)
+ xyplot(a0, data, atypes.col=old.col, ...)
points(a$zas, col=zas.col, pch=zas.pch, ...)
Sys.sleep(bsleep)
- plot(a0, data, atypes.col=old.col, ...)
+ xyplot(a0, data, atypes.col=old.col, ...)
points(a$zas, col=zas.col, pch=zas.pch, ...)
par(new=TRUE)
- plot(a, data, ...)
+ xyplot(a, data, ...)
Sys.sleep(bsleep)
}
@@ -113,6 +111,7 @@
#' @param ... Passed to underlying pcplot functions.
#' @return Undefined.
#' @export
+#' @rdname movieplot
moviepcplot <- function(zs, data, show=c('atypes', 'adata'),
ssleep=0, bsleep=0, ...) {
Modified: branches/pkg-robust/R/archetypes-panorama.R
===================================================================
--- branches/pkg-robust/R/archetypes-panorama.R 2010-03-26 08:13:37 UTC (rev 34)
+++ branches/pkg-robust/R/archetypes-panorama.R 2010-03-31 15:58:20 UTC (rev 35)
@@ -1,19 +1,41 @@
+#' Generic function for panorama plot.
+#' @param object An object.
+#' @param ... Further arguments.
+#' @export
+#' @nord
panorama <- function(object, ...) {
UseMethod('panorama')
}
+#' Panorma plot for archetypes.
+#' @param object An \code{\link{archetypes}}-related object.
+#' @param data A matrix or data frame.
+#' @param distfn Distance function.
+#' @param xlab Label of xaxis.
+#' @param ylab Label of yaxis.
+#' @param order Order the distances.
+#' @param col Color of distances.
+#' @param pch Plot character of distances.
+#' @param cex magnification of the distances.
+#' @param atypes.col Color of archetype distances.
+#' @param atypes.pch Plot character of archetype distances.
+#' @param atypes.cex magnification of the archetype distances.
+#' @param ... Passed to the underlying \code{plot} call.
+#' @S3method panorama archetypes
+#' @method panorama archetypes
panorama.archetypes <- function(object, data, distfn = distEuclidean,
- ref.order = NULL, xlab = 'Index',
- ylab = 'Distance', col = 1, pch = 1,
- atypes.col = (seq(length = ntypes(object)) + 1),
- atypes.pch = rep(19, ntypes(object)), ...) {
+ xlab = 'Index', ylab = 'Distance',
+ order = TRUE, col = 1, pch = 1, cex = 1,
+ atypes.col = (seq(length = nparameters(object)) + 1),
+ atypes.pch = rep(19, nparameters(object)),
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/archetypes -r 35
More information about the Archetypes-commits
mailing list