[Archetypes-commits] r55 - in branches: . pkg-v2 pkg-v2/R pkg-v2/demo pkg-v2/inst pkg-v2/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Apr 26 14:57:43 CEST 2012
Author: manuel
Date: 2012-04-26 14:57:43 +0200 (Thu, 26 Apr 2012)
New Revision: 55
Added:
branches/pkg-v2/
branches/pkg-v2/DESCRIPTION
branches/pkg-v2/NAMESPACE
branches/pkg-v2/NEWS
branches/pkg-v2/R/archetypes-class.R
branches/pkg-v2/R/archetypes-kit-blocks.R
branches/pkg-v2/R/archetypes-kit.R
branches/pkg-v2/R/archetypes-pcplot.R
branches/pkg-v2/R/archetypes-robust.R
branches/pkg-v2/R/archetypes-step.R
branches/pkg-v2/R/archetypes-weighted.R
branches/pkg-v2/R/archetypes-xyplot.R
branches/pkg-v2/R/generics.R
branches/pkg-v2/R/memento.R
branches/pkg-v2/R/panorama.R
branches/pkg-v2/R/pcplot.R
branches/pkg-v2/R/plot.R
branches/pkg-v2/R/profile.R
branches/pkg-v2/R/skeletonplot.R
branches/pkg-v2/demo/00Index
branches/pkg-v2/demo/robust-simulation.R
branches/pkg-v2/inst/opt/
Removed:
branches/pkg-v2/DESCRIPTION
branches/pkg-v2/NEWS
branches/pkg-v2/R/archetypes-barplot.R
branches/pkg-v2/R/archetypes-class.R
branches/pkg-v2/R/archetypes-deprecated.R
branches/pkg-v2/R/archetypes-kit-blocks.R
branches/pkg-v2/R/archetypes-kit.R
branches/pkg-v2/R/archetypes-panorama.R
branches/pkg-v2/R/archetypes-pcplot.R
branches/pkg-v2/R/archetypes-robust.R
branches/pkg-v2/R/archetypes-screeplot.R
branches/pkg-v2/R/archetypes-step.R
branches/pkg-v2/R/archetypes-weighted.R
branches/pkg-v2/R/archetypes-xyplot.R
branches/pkg-v2/R/memento.R
branches/pkg-v2/R/pcplot.R
branches/pkg-v2/R/skeletonplot.R
branches/pkg-v2/demo/00Index
branches/pkg-v2/man/archetypes-deprecated.Rd
branches/pkg-v2/man/archetypes-generics.Rd
Log:
This is archetypes2; new branch created.
Deleted: branches/pkg-v2/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2010-05-06 07:22:09 UTC (rev 43)
+++ branches/pkg-v2/DESCRIPTION 2012-04-26 12:57:43 UTC (rev 55)
@@ -1,14 +0,0 @@
-Package: archetypes
-Type: Package
-Title: Archetypal Analysis
-Version: 2.0-1
-Date: 2010-05-06
-Depends: methods, stats, 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.
-License: GPL (>= 2)
-Revision: 43
Copied: branches/pkg-v2/DESCRIPTION (from rev 53, pkg/DESCRIPTION)
===================================================================
--- branches/pkg-v2/DESCRIPTION (rev 0)
+++ branches/pkg-v2/DESCRIPTION 2012-04-26 12:57:43 UTC (rev 55)
@@ -0,0 +1,42 @@
+Package: archetypes
+Type: Package
+Title: Archetypal Analysis
+Version: 2.1-0
+Date: 2011-10-25
+Depends:
+ methods,
+ stats,
+ modeltools,
+ nnls (>= 1.1),
+ ggplot2
+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: A framework for archetypal analysis supporting
+ arbitary problem solving mechanisms for the different
+ conceputal parts of the algorithm.
+License: GPL (>= 2)
+Revision: 44
+Collate:
+ 'generics.R'
+ 'archetypes-class.R'
+ 'archetypes-kit-blocks.R'
+ 'archetypes-kit.R'
+ 'archetypes-movie.R'
+ 'pcplot.R'
+ 'archetypes-pcplot.R'
+ 'archetypes-robust.R'
+ 'archetypes-screeplot.R'
+ 'archetypes-step.R'
+ 'archetypes-weighted.R'
+ 'archetypes-xyplot.R'
+ 'memento.R'
+ 'skeletonplot.R'
+ 'panorama.R'
+ 'profile.R'
+ 'plot.R'
Copied: branches/pkg-v2/NAMESPACE (from rev 53, pkg/NAMESPACE)
===================================================================
--- branches/pkg-v2/NAMESPACE (rev 0)
+++ branches/pkg-v2/NAMESPACE 2012-04-26 12:57:43 UTC (rev 55)
@@ -0,0 +1,55 @@
+export(archetypes)
+export(archetypesFamily)
+export(as.archetypes)
+export(bestModel)
+export(jd)
+export(moviepcplot)
+export(movieplot)
+export(movieplot2)
+export(new.memento)
+export(nparameters)
+export(panorama)
+export(pcplot)
+export(robustArchetypes)
+export(rss)
+export(skeletonplot)
+export(stepArchetypes)
+export(weightedArchetypes)
+export(xyplot)
+exportMethods(parameters)
+exportMethods(profile)
+importFrom(modeltools,parameters)
+importFrom(stats,coef)
+importFrom(stats,fitted)
+importFrom(stats,profile)
+importFrom(stats,residuals)
+importFrom(stats,screeplot)
+importFrom(stats,weights)
+S3method("[",stepArchetypes)
+S3method(barplot,atypes_parameters)
+S3method(barplot,atypes_profile)
+S3method(bestModel,stepArchetypes)
+S3method(coef,archetypes)
+S3method(fitted,archetypes)
+S3method(kappa,archetypes)
+S3method(nparameters,archetypes)
+S3method(nparameters,stepArchetypes)
+S3method(panorama,archetypes)
+S3method(pcplot,archetypes)
+S3method(pcplot,default)
+S3method(plot,atypes_profile)
+S3method(plot,stepArchetypes)
+S3method(plot,stepArchetypes_parameters)
+S3method(plot,stepArchetypes_profile)
+S3method(print,archetypes)
+S3method(print,stepArchetypes)
+S3method(residuals,archetypes)
+S3method(rss,archetypes)
+S3method(rss,stepArchetypes)
+S3method(screeplot,stepArchetypes)
+S3method(weights,archetypes)
+S3method(xyplot,archetypes)
+S3method(xyplot,atypes_panorama)
+S3method(xyplot,robustArchetypes)
+S3method(xyplot,stepArchetypes)
+S3method(xyplot,weightedArchetypes)
Deleted: branches/pkg-v2/NEWS
===================================================================
--- pkg/NEWS 2010-05-06 07:22:09 UTC (rev 43)
+++ branches/pkg-v2/NEWS 2012-04-26 12:57:43 UTC (rev 55)
@@ -1,26 +0,0 @@
-
-Changes in archetypes version 2.0-1
-
- o 'no.scalefn' returns an empty matrix if 'zs' is null.
-
- o 'xyplot.weightedArchetypes' displays the main diagonal if
- 'weights' is a matrix.
-
- o Technical report on robust and weighted archetypes is cited.
-
-
-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'.
-
-
Copied: branches/pkg-v2/NEWS (from rev 52, pkg/NEWS)
===================================================================
--- branches/pkg-v2/NEWS (rev 0)
+++ branches/pkg-v2/NEWS 2012-04-26 12:57:43 UTC (rev 55)
@@ -0,0 +1,50 @@
+
+Changes in archetypes version 2.1-0
+
+ o Harmonized weights with reweights; default weights are now 1 for
+ evey observation of the data set (not NULL).
+
+ o Simplified stepArchetypes and removed the
+ repArchetypes-abstraction.
+
+ o ggplot2-ified and introduced a clean abstraction between data and
+ visualization; e.g., 'panorama' now returns the panorama data with
+ a class attribute and 'plot' visualizes the panorama.
+
+ o roxygen2-ified; added the Build-dep field to the DESCRIPTION
+ file.
+
+ o Removed deprecated functions.
+
+
+Changes in archetypes version 2.0-2
+
+ o Added analysis of the simulation study for robust archetypes
+ as demo.
+
+
+Changes in archetypes version 2.0-1
+
+ o 'no.scalefn' returns an empty matrix if 'zs' is null.
+
+ o 'xyplot.weightedArchetypes' displays the main diagonal if
+ 'weights' is a matrix.
+
+ o Technical report on robust and weighted archetypes is cited.
+
+
+Changes in archetypes version 2.0-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'.
+
+
Deleted: branches/pkg-v2/R/archetypes-barplot.R
===================================================================
--- pkg/R/archetypes-barplot.R 2010-05-06 07:22:09 UTC (rev 43)
+++ branches/pkg-v2/R/archetypes-barplot.R 2012-04-26 12:57:43 UTC (rev 55)
@@ -1,108 +0,0 @@
-
-
-#' Barplot of archetypes.
-#' @param height An \code{\link{archetypes}} object.
-#' @param data The original data matrix.
-#' @param which \code{below} creates a barplot for each archetype,
-#' \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 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 col.atypes Color of archetypes; only used in \code{below.compressed}.
-#' @param ... Passed to the underlying \code{\link{barplot}} call.
-#' @return Undefined.
-#' @method barplot archetypes
-#' @importFrom graphics barplot
-#' @export
-barplot.archetypes <- function(height, data,
- which = c('below', 'beside'),
- which.beside = c('atypes', 'variables'),
- which.below = c('compressed', 'default'),
- percentiles = FALSE,
- below.compressed.height = 0.1,
- below.compressed.srt = 0,
- col.atypes = NULL, ...) {
-
- ### 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)
-
- layout(matrix(1:p, nrow = p, byrow = TRUE))
- for ( i in 1:p )
- barplot(atypes[i,], main=paste('Archetype', i),
- 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),
- 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, col = col.atypes[i], ...)
- mtext(sprintf('Archetype %s', i), side = 2, line = 4,
- cex = par('cex'))
- }
-
- 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 <- parameters(height)
- rownames(atypes) <- sprintf('Archetype %s',
- seq(length = nrow(atypes)))
-
- if ( !percentiles ) {
- ylab <- 'Value'
- ylim <- NULL
- }
- else {
- 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())
-
- invisible(atypes)
-}
-
Deleted: branches/pkg-v2/R/archetypes-class.R
===================================================================
--- pkg/R/archetypes-class.R 2010-05-06 07:22:09 UTC (rev 43)
+++ branches/pkg-v2/R/archetypes-class.R 2012-04-26 12:57:43 UTC (rev 55)
@@ -1,247 +0,0 @@
-
-
-#' 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;
-#' @param alphas The coefficients; a \eqn{n \times p} matrix, see
-#' \code{\link{alphas}}.
-#' @param rss The residual sum of squares; see \link{rss}.
-#' @param iters The number of iterations to the convergence.
-#' @param call The call of the \code{\link{archetypes}} function.
-#' @param history If \code{saveHistory} set then an environment with the
-#' archetypes object for each execution step;
-#' @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}}
-#' @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.
-#' @param ... Ignored.
-#' @return Undefined.
-#' @method print archetypes
-#' @S3method print archetypes
-#' @nord
-print.archetypes <- function(x, full = TRUE, ...) {
- if ( full ) {
- cat('Archetypes object\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 = '')
-}
-
-
-
-#' 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
-#' @importFrom stats fitted
-#' @S3method fitted archetypes
-#' @rdname archetypes-class
-fitted.archetypes <- function(object, ...) {
- t(t(object$archetypes) %*% t(object$alphas))
-}
-
-
-
-#' Return fitted archetypes.
-#' @param object An \code{archetypes} object.
-#' @param ... Ignored.
-#' @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)
-
-
-
-#' Return coefficients.
-#' @param object An \code{archetypes} object.
-#' @param type Return alphas or betas.
-#' @param ... Ignored.
-#' @return Coefficient matrix.
-#' @method coef archetypes
-#' @importFrom stats coef
-#' @S3method coef archetypes
-#' @rdname archetypes-class
-coef.archetypes <- function(object, type = c('alphas', 'betas'), ...) {
- type <- match.arg(type)
- object[[type]]
-}
-
-
-#' Return residuals.
-#' @param object An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return Matrix with residuals.
-#' @method residuals archetypes
-#' @importFrom stats residuals
-#' @S3method residuals archetypes
-#' @rdname archetypes-class
-residuals.archetypes <- function(object, ...) {
- object$residuals
-}
-
-
-
-#' Residual sum of squares.
-#' @param object An object.
-#' @param ... Ignored.
-#' @return Residual sum of squares.
-#' @export
-#' @rdname archetypes-generics
-rss <- function(object, ...) {
- UseMethod('rss')
-}
-
-#' Residual sum of squares getter.
-#' @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
-#' @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))
-}
-
-
-
-#' 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 Vector of weights.
-#' @method weights archetypes
-#' @importFrom stats weights
-#' @S3method weights archetypes
-#' @rdname archetypes-class
-weights.archetypes <- function(object, type = c('weights', 'reweights'), ...) {
- type <- match.arg(type)
- object[[type]]
-}
-
-
-
-#' 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.
-#' @param ... Ignored.
-#' @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.')
-
- ### Something like the following ...
- #if ( type == 'alphas' )
- # object$family$alphasfn(NULL, t(object$archetypes), t(newdata))
-}
-
-
-
-#' Number of parameters.
-#' @param object An object.
-#' @param ... Further arguments.
-#' @return Number of parameters.
-#' @export
-#' @rdname archetypes-generics
-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)
-}
Copied: branches/pkg-v2/R/archetypes-class.R (from rev 53, pkg/R/archetypes-class.R)
===================================================================
--- branches/pkg-v2/R/archetypes-class.R (rev 0)
+++ branches/pkg-v2/R/archetypes-class.R 2012-04-26 12:57:43 UTC (rev 55)
@@ -0,0 +1,267 @@
+#' @include generics.R
+{}
+
+
+
+#' Archetypes object constructor
+#'
+#' @param object The archetypes; a \eqn{p \times m} matrix, see
+#' \code{\link{parameters}}.
+#' @param k The number of archetypes;
+#' @param alphas The coefficients; a \eqn{n \times p} matrix, see
+#' \code{\link{coef}}.
+#' @param rss The residual sum of squares; see \code{\link{rss.archetypes}}.
+#' @param iters The number of iterations to the convergence.
+#' @param call The call of the \code{\link{archetypes}} function.
+#' @param history If \code{saveHistory} set then an environment with the
+#' archetypes object for each execution step;
+#' @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}.
+#'
+#' @family archetypes
+#'
+#' @export
+as.archetypes <- function(object, 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 = object,
+ 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(c("archetypes"))
+
+
+#' @S3method print archetypes
+print.archetypes <- function(x, full = TRUE, ...) {
+ if ( full ) {
+ cat('Archetypes object\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 = '')
+}
+
+
+
+#' Return fitted data
+#'
+#' Returns the approximated data.
+#'
+#' @param object An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return Matrix with approximated data.
+#' @method fitted archetypes
+#' @rdname fitted
+#'
+#' @importFrom stats fitted
+#' @S3method fitted archetypes
+fitted.archetypes <- function(object, ...) {
+ t(t(object$archetypes) %*% t(object$alphas))
+}
+
+
+
+#' Return coefficients
+#'
+#' @param object An \code{archetypes} object.
+#' @param type Return alpha or beta coefficients.
+#' @param ... Ignored.
+#' @return Coefficient matrix.
+#' @method coef archetypes
+#' @rdname coef
+#'
+#' @importFrom stats coef
+#' @S3method coef archetypes
+coef.archetypes <- function(object, type = c("alphas", "betas"), ...) {
+ type <- match.arg(type)
+ object[[type]]
+}
+
+
+
+#' Return number of archetypes
+#'
+#' @param object An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return Number of archetypes.
+#' @rdname nparameters
+#'
+#' @method nparameters archetypes
+#' @S3method nparameters archetypes
+nparameters.archetypes <- function(object, ...) {
+ return(object$k)
+}
+
+
+
+#' Return residuals
+#'
+#' @param object An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return Matrix with residuals.
+#' @method residuals archetypes
+#' @rdname residuals
+#'
+#' @importFrom stats residuals
+#' @S3method residuals archetypes
+residuals.archetypes <- function(object, ...) {
+ object$residuals
+}
+
+
+
+#' 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 Vector of weights.
+#' @method weights archetypes
+#' @rdname weights
+#'
+#' @importFrom stats weights
+#' @S3method weights archetypes
+weights.archetypes <- function(object, type = c('weights', 'reweights'), ...) {
+ type <- match.arg(type)
+ object[[type]]
+}
+
+
+
+#' Return kappa
+#'
+#' @param z An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return A vector of kappas.
+#' @rdname kappa
+#'
+#' @method kappa archetypes
+#' @S3method kappa archetypes
+kappa.archetypes <- function(z, ...) {
+ return(z$kappas)
+}
+
+
+
+#' Return residual sum of squares
+#'
+#' @param object An \code{archetypes} object.
+#' @param type Return scaled, single or global RSS.
+#' @param ... Ignored.
+#' @return Residual sum of squares.
+#' @method rss archetypes
+#' @rdname rss
+#'
+#' @S3method rss archetypes
+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))
+}
+
+
+
+#' Fitted archetypes
+#'
+#' @param object An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return Matrix (with class \code{atypes_parameters}) with \eqn{k}
+#' archetypes.
+#'
+#' @aliases parameters-methods
+#' @aliases parameters,archetypes-method
+#'
+#' @seealso \code{\link{profile,archetypes-method}}
+#'
+#' @importFrom modeltools parameters
+#' @exportMethod parameters
+setMethod('parameters', signature = c(object = 'archetypes'),
+function(object, ...) {
+ parameters <- object$archetypes
+
+ if ( is.null(parameters) )
+ return(parameters)
+
+
+ rownames(parameters) <- sprintf("Archetype %s",
+ seq(length = object$k))
+
+ subclass(parameters, "atypes_parameters")
+})
+
+
+
+#' @param height An \code{atypes_parameters} object.
+#' @rdname parameters
+#' @method barplot atypes_parameters
+#' @S3method barplot atypes_parameters
+barplot.atypes_parameters <- function(height, ...) {
+ p <- ggplot(melt(height), aes(X2, value))
+ p <- p + geom_bar(stat = "identity") + facet_grid(X1 ~ .)
+ p <- p + xlab("Variable") + ylab("Value")
+ p
+}
+
+
+
+#' @param x An \code{atypes_parameters} object.
+#' @param y Ignored.
+#' @rdname parameters
+#' @method plot atypes_profile
+#' @S3method plot atypes_profile
+plot.atypes_parameters <- function(x, y = NULL, ...) {
+ barplot.atypes_parameters(x, ...)
+}
+
+
+
+### Not implemented yet: #############################################
+
+predict.archetypes <- function(object, newdata = NULL,
+ typxe = 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.')
+
+ ### Something like the following ...
+ #if ( type == 'alphas' )
+ # object$family$alphasfn(NULL, t(object$archetypes), t(newdata))
+}
Deleted: branches/pkg-v2/R/archetypes-deprecated.R
===================================================================
--- pkg/R/archetypes-deprecated.R 2010-05-06 07:22:09 UTC (rev 43)
+++ branches/pkg-v2/R/archetypes-deprecated.R 2012-04-26 12:57:43 UTC (rev 55)
@@ -1,212 +0,0 @@
-
-
-#' 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))
-}
-
Deleted: branches/pkg-v2/R/archetypes-kit-blocks.R
===================================================================
--- pkg/R/archetypes-kit-blocks.R 2010-05-06 07:22:09 UTC (rev 43)
+++ branches/pkg-v2/R/archetypes-kit-blocks.R 2012-04-26 12:57:43 UTC (rev 55)
@@ -1,444 +0,0 @@
-
-
-### 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
-
- s = apply(x, 1, sd)
- x = x / s
-
- attr(x, '.Meta') = list(mean=m, sd=s)
-
- return(x)
-}
-
-#' Rescaling block: counterpart of std.scalefn.
-#' @param x Standardized data matrix.
-#' @param zs Archetypes matrix
-#' @return Rescaled archetypes.
-#' @nord
-std.rescalefn <- function(x, zs, ...) {
-
- m = attr(x, '.Meta')$mean
- s = attr(x, '.Meta')$sd
-
- zs = zs * s
- zs = zs + m
-
- return(zs)
-}
-
-
-
-#' Scaling block: no scaling.
-#' @param x Data matrix.
-#' @return Data matrix.
-#' @nord
-no.scalefn <- function(x, ...) {
- return(x)
-}
-
-#' Rescaling block: counterpart of no.scalefn.
-#' @param x Data matrix.
-#' @param zs Archetypes matrix.
-#' @return Archetypes zs.
-#' @nord
-no.rescalefn <- function(x, zs, ...) {
- if ( is.null(zs) )
- return(matrix(NA, nrow = 0, ncol = 0))
-
- return(zs)
-}
-
-
-
-### Dummy and undummy functions: #####################################
-
-#' 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.
-#' @nord
-make.dummyfn <- function(huge=200) {
-
- 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)
- }
-
- return(bp.dummyfn)
-}
-
-
-#' Undummy block: remove dummy row.
-#' @param x Data matrix.
-#' @param zs Archetypes matrix.
-#' @return Archetypes zs.
-#' @nord
-rm.undummyfn <- function(x, zs, ...) {
- dr = attr(x, '.Meta')$dummyrow
-
- return(zs[-dr,])
-}
-
-
-#' Dummy block: no dummy row.
-#' @param x Data matrix.
-#' @return Data matrix x.
-#' @nord
-no.dummyfn <- function(x, ...) {
- return(x)
-}
-
-#' Undummy block: return archetypes..
-#' @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: ######################
-
-
-#' 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)))
-}
-
-
-
-#' X to alpha block: pseudo-inverse approach.
-#' @param alphas The coefficients.
-#' @param x Data matrix.
-#' @return The solved linear system.
-#' @nord
-ginv.zalphasfn <- function(alphas, x, ...) {
- require(MASS)
-
- return(t(ginv(alphas %*% t(alphas)) %*% alphas %*% t(x)))
-}
-
-
-
-#' X to alpha block: optim approach.
-#' @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))
-
- fun <- function(z){
- z <- matrix(z, ncol=nrow(alphas))
- sum( (x - z %*% alphas)^2)
- }
-
- z <- optim(z, fun, method="BFGS")
- z <- matrix(z$par, ncol=nrow(alphas))
-
- return(z)
-}
-
-
-
-### 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)
-
- n = ncol(d)
-
- for ( j in 1:n )
- coefs[,j] = coef(nnls(C, d[,j]))
-
- return(coefs)
-}
-
-#' Alpha block: nnls with singular value decomposition.
-#' @param coefs The coefficients alpha.
-#' @param C The archetypes matrix.
-#' @param d The data matrix.
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/archetypes -r 55
More information about the Archetypes-commits
mailing list