[Archetypes-commits] r56 - in pkg: . R inst/doc man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Apr 26 15:33:11 CEST 2012
Author: manuel
Date: 2012-04-26 15:33:11 +0200 (Thu, 26 Apr 2012)
New Revision: 56
Added:
pkg/R/archetypes-barplot.R
pkg/R/archetypes-panorama.R
pkg/R/archetypes-screeplot.R
pkg/man/archetypes-generics.Rd
pkg/man/archetypes.Rd
pkg/man/archetypesFamily.Rd
pkg/man/as.archetypes.Rd
pkg/man/barplot.archetypes.Rd
pkg/man/bestModel.Rd
pkg/man/coef.Rd
pkg/man/extract.Rd
pkg/man/fitted.Rd
pkg/man/kappa.Rd
pkg/man/movieplot.Rd
pkg/man/nparameters.Rd
pkg/man/panorama.archetypes.Rd
pkg/man/parameters.Rd
pkg/man/pcplot.Rd
pkg/man/pcplot.archetypes.Rd
pkg/man/pcplot.default.Rd
pkg/man/residuals.Rd
pkg/man/robustArchetypes.Rd
pkg/man/rss.Rd
pkg/man/screeplot.stepArchetypes.Rd
pkg/man/skeletonplot.Rd
pkg/man/stepArchetypes.Rd
pkg/man/summary.Rd
pkg/man/weightedArchetypes.Rd
pkg/man/weights.Rd
pkg/man/xyplot.Rd
pkg/man/xyplot.archetypes.Rd
pkg/man/xyplot.robustArchetypes.Rd
pkg/man/xyplot.stepArchetypes.Rd
pkg/man/xyplot.weightedArchetypes.Rd
Removed:
pkg/R/panorama.R
pkg/R/plot.R
pkg/R/profile.R
Modified:
pkg/DESCRIPTION
pkg/NAMESPACE
pkg/NEWS
pkg/R/archetypes-class.R
pkg/R/archetypes-movie.R
pkg/R/archetypes-step.R
pkg/R/generics.R
pkg/R/memento.R
pkg/inst/doc/archetypes.Rnw
Log:
back to "old" version
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2012-04-26 12:57:43 UTC (rev 55)
+++ pkg/DESCRIPTION 2012-04-26 13:33:11 UTC (rev 56)
@@ -7,27 +7,30 @@
methods,
stats,
modeltools,
- nnls (>= 1.1),
- ggplot2
+ nnls (>= 1.1)
Suggests:
MASS,
vcd,
mlbench,
+ ggplot2
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.
+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: 44
Collate:
+ 'archetypes-barplot.R'
'generics.R'
'archetypes-class.R'
'archetypes-kit-blocks.R'
'archetypes-kit.R'
'archetypes-movie.R'
+ 'archetypes-panorama.R'
'pcplot.R'
'archetypes-pcplot.R'
'archetypes-robust.R'
@@ -37,6 +40,3 @@
'archetypes-xyplot.R'
'memento.R'
'skeletonplot.R'
- 'panorama.R'
- 'profile.R'
- 'plot.R'
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2012-04-26 12:57:43 UTC (rev 55)
+++ pkg/NAMESPACE 2012-04-26 13:33:11 UTC (rev 56)
@@ -6,7 +6,6 @@
export(moviepcplot)
export(movieplot)
export(movieplot2)
-export(new.memento)
export(nparameters)
export(panorama)
export(pcplot)
@@ -17,39 +16,37 @@
export(weightedArchetypes)
export(xyplot)
exportMethods(parameters)
-exportMethods(profile)
+importFrom(graphics,barplot)
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(barplot,archetypes)
+S3method(bestModel,repArchetypes)
S3method(bestModel,stepArchetypes)
S3method(coef,archetypes)
S3method(fitted,archetypes)
S3method(kappa,archetypes)
S3method(nparameters,archetypes)
+S3method(nparameters,repArchetypes)
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,repArchetypes)
S3method(print,stepArchetypes)
S3method(residuals,archetypes)
S3method(rss,archetypes)
+S3method(rss,repArchetypes)
S3method(rss,stepArchetypes)
S3method(screeplot,stepArchetypes)
+S3method(summary,stepArchetypes)
S3method(weights,archetypes)
S3method(xyplot,archetypes)
-S3method(xyplot,atypes_panorama)
S3method(xyplot,robustArchetypes)
S3method(xyplot,stepArchetypes)
S3method(xyplot,weightedArchetypes)
Modified: pkg/NEWS
===================================================================
--- pkg/NEWS 2012-04-26 12:57:43 UTC (rev 55)
+++ pkg/NEWS 2012-04-26 13:33:11 UTC (rev 56)
@@ -1,14 +1,7 @@
Changes in archetypes version 2.1-0
- o separated 'repArchetypes' and 'stepArchetypes' to simplify
- parallel computation.
-
- 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
+ o Roxygen2-ified; added the Build-dep field to the DESCRIPTION
file.
o Removed deprecated functions.
Copied: pkg/R/archetypes-barplot.R (from rev 50, pkg/R/archetypes-barplot.R)
===================================================================
--- pkg/R/archetypes-barplot.R (rev 0)
+++ pkg/R/archetypes-barplot.R 2012-04-26 13:33:11 UTC (rev 56)
@@ -0,0 +1,108 @@
+
+
+#' 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)
+}
+
Modified: pkg/R/archetypes-class.R
===================================================================
--- pkg/R/archetypes-class.R 2012-04-26 12:57:43 UTC (rev 55)
+++ pkg/R/archetypes-class.R 2012-04-26 13:33:11 UTC (rev 56)
@@ -89,6 +89,24 @@
+#' Return fitted archetypes
+#'
+#' @param object An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return Matrix with \eqn{k} archetypes.
+#'
+#' @aliases parameters-methods
+#' @aliases parameters,archetypes-method
+#'
+#' @importFrom modeltools parameters
+#' @exportMethod parameters
+setMethod('parameters', signature = c(object = 'archetypes'),
+function(object, ...) {
+ object$archetypes
+})
+
+
+
#' Return coefficients
#'
#' @param object An \code{archetypes} object.
@@ -100,28 +118,13 @@
#'
#' @importFrom stats coef
#' @S3method coef archetypes
-coef.archetypes <- function(object, type = c("alphas", "betas"), ...) {
+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.
@@ -138,6 +141,28 @@
+#' 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))
+}
+
+
+
#' Return weights
#'
#' @param object An \code{archetypes} object.
@@ -172,86 +197,25 @@
-#' Return residual sum of squares
+#' Return number of archetypes
#'
#' @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
+#' @return Number of archetypes.
+#' @rdname nparameters
#'
-#' @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))
+#' @method nparameters archetypes
+#' @S3method nparameters archetypes
+nparameters.archetypes <- function(object, ...) {
+ return(object$k)
}
-#' 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 = c('alphas', 'data'), ...) {
type <- match.arg(type)
if ( is.null(newdata) )
Modified: pkg/R/archetypes-movie.R
===================================================================
--- pkg/R/archetypes-movie.R 2012-04-26 12:57:43 UTC (rev 55)
+++ pkg/R/archetypes-movie.R 2012-04-26 13:33:11 UTC (rev 56)
@@ -55,15 +55,9 @@
#'
#' Shows the intermediate steps of the algorithm;
#'
-#' @param zs An \code{\link{archetypes}} object.
-#' @param data The data matrix.
-#' @param show Shows only archetypes currently.
-#' @param ssleep Seconds to sleep before start.
-#' @param bsleep Seconds to sleep between each plot.
#' @param zas.col Color of the intermediate archetypes.
#' @param zas.pch Type of the intermediate archetypes points.
#' @param old.col Color of the archetypes on step further.
-#' @param ... Passed to underlying plot functions.
#' @return Undefined.
#' @export
#' @rdname movieplot
@@ -102,12 +96,6 @@
#' Archetypes parallel coordinates plot movie.
-#' @param zs An \code{\link{archetypes}} object.
-#' @param data The data matrix.
-#' @param show Show archetypes or approximated data.
-#' @param ssleep Seconds to sleep before start.
-#' @param bsleep Seconds to sleep between each plot.
-#' @param ... Passed to underlying pcplot functions.
#' @return Undefined.
#' @export
#' @rdname movieplot
Copied: pkg/R/archetypes-panorama.R (from rev 50, pkg/R/archetypes-panorama.R)
===================================================================
--- pkg/R/archetypes-panorama.R (rev 0)
+++ pkg/R/archetypes-panorama.R 2012-04-26 13:33:11 UTC (rev 56)
@@ -0,0 +1,106 @@
+
+
+
+#' 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 ylim The y limits of the plot.
+#' @param ... Passed to the underlying \code{plot} call.
+#' @S3method panorama archetypes
+#' @method panorama archetypes
+#' @examples
+#' \dontrun{
+#' data(toy)
+#' a <- archetypes(toy, 3)
+#' panorama(a, toy)
+#'
+#' ## See demo(robust-ozone).
+#' }
+panorama.archetypes <- function(object, data, distfn = distEuclidean,
+ 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)),
+ atypes.cex = rep(1, nparameters(object)),
+ ylim = NULL, ...) {
+
+ n1 <- nrow(data)
+ n2 <- nparameters(object)
+
+ data <- rbind(data, parameters(object))
+ dist <- distfn(data, parameters(object))
+
+ x <- seq(length = n1 + n2)
+
+ col <- c(rep(col, n1), atypes.col)
+ pch <- c(rep(pch, n1), atypes.pch)
+ cex <- c(rep(cex, n1), atypes.cex)
+
+ #if ( is.null(ref.order) )
+ # ix <- x
+ #else
+ # ix <- order(dist[, ref.order])
+
+ ix <- x
+ r <- x
+
+ opar <- par(no.readonly = TRUE)
+ on.exit(par(opar))
+
+ if ( is.null(ylim) )
+ ylim <- c(0, max(dist))
+
+ mar <- opar$mar
+ mar[2] <- max(mar[2], 5)
+
+ layout(matrix(seq(length = n2), nrow = n2, byrow = TRUE))
+ par(mar = mar, cex = opar$cex)
+
+ for ( i in seq(length = n2) ) {
+ if ( order ) {
+ ix <- order(dist[, i])
+ r <- rank(dist[, i])
+ }
+
+ plot(x, dist[ix, i], ylim = ylim, xlab = xlab,
+ ylab = ylab, col = col[ix], pch = pch[ix], cex = cex[ix], ...)
+
+ or <- tail(r, n2)
+ points(or, dist[tail(x, n2), i], pch = atypes.pch,
+ cex = atypes.cex, col = atypes.col)
+
+ mtext(sprintf('Archetype %s', i), side = 2, line = 4,
+ cex = par('cex'))
+ }
+
+
+ invisible(dist)
+}
+
+
+
+#' Euclidean distance function (copied from flexclust)
+#' @param x Data matrix.
+#' @param centers Archetypes
+#' @return Matrix with euclidean distance between each
+#' data point and each center.
+#' @noRd
+distEuclidean <- function (x, centers) {
+ if (ncol(x) != ncol(centers))
+ stop(sQuote("x"), " and ", sQuote("centers"), " must have the same number of columns")
+ z <- matrix(0, nrow = nrow(x), ncol = nrow(centers))
+ for (k in 1:nrow(centers)) {
+ z[, k] <- sqrt(colSums((t(x) - centers[k, ])^2))
+ }
+ z
+}
Copied: pkg/R/archetypes-screeplot.R (from rev 50, pkg/R/archetypes-screeplot.R)
===================================================================
--- pkg/R/archetypes-screeplot.R (rev 0)
+++ pkg/R/archetypes-screeplot.R 2012-04-26 13:33:11 UTC (rev 56)
@@ -0,0 +1,28 @@
+
+
+#' Screeplot of stepArchetypes.
+#'
+#' Screeplot draws the residual sum of square curve based on the best
+#' model of each step.
+#'
+#' @param x A \code{\link{stepArchetypes}} object.
+#' @param type Draw lines or a barplot.
+#' @param ... Passed to underlying plot functions.
+#' @return Undefined.
+#' @importFrom stats screeplot
+#' @method screeplot stepArchetypes
+#' @S3method screeplot stepArchetypes
+screeplot.stepArchetypes <- function(x, type=c('lines', 'barplot'), ...) {
+ zs <- bestModel(x)
+
+ a <- sapply(zs, nparameters)
+ b <- sapply(zs, rss)
+
+ if ( type[1] == 'lines' ) {
+ plot(a, b, type='b', xlab='Archetypes', ylab='RSS', ...)
+ axis(1, at=a, ...)
+ }
+ else {
+ barplot(b, names.arg=a, xlab='Archetypes', ylab='RSS', ...)
+ }
+}
Modified: pkg/R/archetypes-step.R
===================================================================
--- pkg/R/archetypes-step.R 2012-04-26 12:57:43 UTC (rev 55)
+++ pkg/R/archetypes-step.R 2012-04-26 13:33:11 UTC (rev 56)
@@ -4,10 +4,6 @@
#' Run archetypes algorithm repeatedly
#'
-#' Run archetypes algorithm repeatedly for different numbers of
-#' archetypes. One step is defined by the number of archetypes
-#' \code{k} and the number of replications \code{nrep}.
-#'
#' @param ... Passed to the specific archetype function.
#' @param k A vector of integers passed in turn to the k argument of
#' \code{\link{archetypes}}.
@@ -18,11 +14,12 @@
#' \code{\link{robustArchetypes}},
#' @param verbose Show progress during exection.
#'
-#' @return A list with \code{length(k)} elements and class attribute
-#' \code{stepArchetypes}.
+#' @return A list with \code{k} elements and class attribute
+#' \code{stepArchetypes}. Each element is a list of class
+#' \code{repArchetypes} with \code{nrep} elements; only for internal
+#' usage.
#'
-#' @family archetypes
-#' @seealso \code{\link{bestModel}}
+#' @seealso \code{\link{archetypes}}
#'
#' @examples
#' \dontrun{
@@ -40,40 +37,32 @@
#'
#' @export
stepArchetypes <- function(..., k, nrep = 3, method = archetypes, verbose = TRUE) {
- stopifnot(nrep > 0)
+ mycall <- match.call()
as <- list()
- as$call <- match.call(expand.dots = TRUE)
- as$nrep <- nrep
- as$k <- k
- as$models <- list()
- for ( i in seq(along = k) ) {
- as$models[[i]] <- step()
- for ( j in seq(length = nrep) ) {
- as$models[[i]][[j]] <- method(..., k = k[i], verbose = verbose)
+ for ( i in 1:length(k) ) {
+ as[[i]] <- list()
+ class(as[[i]]) <- 'repArchetypes'
+
+ for ( j in seq_len(nrep) ) {
+ if ( verbose )
+ cat('\n*** k=', k[i], ', rep=', j, ':\n', sep='')
+
+ as[[i]][[j]] <- method(..., k=k[i])
}
}
- subclass(as, "stepArchetypes")
+ return(structure(as, class='stepArchetypes', call=mycall))
}
-setOldClass("stepArchetypes")
+setOldClass('repArchetypes')
+setOldClass('stepArchetypes')
-#' @S3method print stepArchetypes
-print.stepArchetypes <- function(x, ...) {
- cat("stepArchetypes object\n\n")
- cat(deparse(x$call), "\n\n")
- cat("Residual sum of squares:\n")
- print(round(rss(x), 2))
-}
-
-
-
#' Extract method
#'
#' An extraction on a \code{stepArchetypes} object returns again a
@@ -96,58 +85,33 @@
-#' @rdname rss
-#' @method rss stepArchetypes
-#'
-#' @S3method rss stepArchetypes
-rss.stepArchetypes <- function(object, ...) {
- ret <- lapply(object$models, rss)
- ret <- do.call(rbind, ret)
- ret <- data.frame(Archetypes = nparameters(object), ret)
- subclass(ret, "stepArchetypes_rss")
+#' @S3method print stepArchetypes
+print.stepArchetypes <- function(x, ...) {
+ cat('StepArchetypes object\n\n')
+ cat(deparse(attr(x, 'call')), '\n')
}
-#' @param x A \code{stepArchetypes_rss} object
-#' @param y Ignored.
-#' @rdname rss
-#' @method plot stepArchetypes
+#' Summary method for stepArchetypes object
#'
-#' @S3method plot stepArchetypes
-plot.stepArchetypes_rss <- function(x, y = NULL, ...) {
- p <- ggplot(melt(x, "Archetypes"),
- aes(ordered(Archetypes), value, group = variable,
- colour = variable))
- p <- p + geom_line()
- p <- p + geom_point()
- p <- p + xlab("Number of archetypes") + ylab("RSS")
- p
-}
-
-
-
-#' Return best model per step
+#' @param object A \code{stepArchetypes} object.
+#' @param ... Ignored.
+#' @return Undefined.
#'
-#' @param object An \code{archetypes} object.
-#' @param reduced Reduce list to valid objects; i.e., remove step if
-#' no replication was successfull.
-#' @param ... Ignored
+#' @method summary stepArchetypes
+#' @rdname summary
#'
-#' @rdname bestModel
-#' @method bestModel stepArchetypes
-#'
-#' @S3method bestModel stepArchetypes
-bestModel.stepArchetypes <- function(object, reduced = TRUE, ...) {
- best <- lapply(object$models, bestModel, reduced = reduced)
+#' @S3method summary stepArchetypes
+summary.stepArchetypes <- function(object, ...) {
+ print(object)
- if ( reduced )
- best <- best[sapply(best, Negate(is.null))]
+ ps <- nparameters(object)
- object$models <- best
- object$k <- sapply(best, sapply, "[[", "k")
- object$nrep <- 1
- object
+ for ( i in seq_along(object) ) {
+ cat('\nk=', ps[i], ':\n', sep='')
+ print(object[[i]], full=FALSE)
+ }
}
@@ -158,88 +122,108 @@
#' @exportMethod parameters
setMethod('parameters', signature = c(object = 'stepArchetypes'),
function(object, ...) {
- subclass(lapply(object$models, parameters), "stepArchetypes_parameters")
+ lapply(object, parameters)
})
-#' @param transpose Transpose plots arrangement.
-#' @rdname parameters
-#' @method plot stepArchetypes_parameters
-#' @S3method plot stepArchetypes_parameters
-plot.stepArchetypes_parameters <- function(x, y = NULL, transpose = FALSE, ...) {
- params_plot(x, transpose)
+#' @rdname nparameters
+#' @method nparameters stepArchetypes
+#'
+#' @S3method nparameters stepArchetypes
+nparameters.stepArchetypes <- function(object, ...) {
+ return(sapply(object, nparameters))
}
-#' @aliases profile,stepArchetypes-method
-#' @rdname profile
-#' @importFrom stats profile
-#' @exportMethod profile
-setMethod('profile', signature = c(fitted = 'stepArchetypes'),
-function(fitted, data, type = percentiles, ...) {
- subclass(lapply(fitted$models, profile, data, type), "stepArchetypes_profile")
-})
+#' @rdname rss
+#' @method rss stepArchetypes
+#'
+#' @S3method rss stepArchetypes
+rss.stepArchetypes <- function(object, ...) {
+ ret <- t(sapply(object, rss))
+ rownames(ret) <- paste('k', nparameters(object), sep='')
+ return(ret)
+}
-#' @param transpose Transpose plots arrangement.
-#' @rdname profile
-#' @method plot stepArchetypes_profile
-#' @S3method plot stepArchetypes_profile
-plot.stepArchetypes_profile <- function(x, y = NULL, transpose = FALSE, ...) {
- params_plot(x, transpose)
+#' Return best model
+#'
+#' @param object An \code{archetypes} object.
+#' @param ... Ignored
+#'
+#' @rdname bestModel
+#' @method bestModel stepArchetypes
+#'
+#' @S3method bestModel stepArchetypes
+bestModel.stepArchetypes <- function(object, ...) {
+ zsmin <- lapply(object, bestModel)
+
+ if ( length(zsmin) == 1 )
+ return(zsmin[[1]])
+ else
+ return(zsmin)
}
-#' @rdname nparameters
-#' @method nparameters stepArchetypes
-#'
-#' @S3method nparameters stepArchetypes
-nparameters.stepArchetypes <- function(object, ...) {
- return(sapply(object$model, nparameters))
+#' @S3method print repArchetypes
+print.repArchetypes <- function(x, ...) {
+ for ( i in seq_along(x) )
+ print(x[[i]], ...)
+
+ invisible(x)
}
-### Step utility functions: ##########################################
+#' @aliases parameters,repArchetypes-method
+#' @rdname parameters
+#' @importFrom modeltools parameters
+#' @exportMethod parameters
+setMethod('parameters', signature = signature(object = 'repArchetypes'),
+function(object, ...) {
+ lapply(object, parameters)
+})
-setOldClass(c("step", "list"))
-step <- function() {
- structure(list(), class = c("step", "list"))
-}
-rss.step <- function(object, ...) {
- rss <- sapply(object, rss)
- names(rss) <- sprintf("Replication%s", seq(along = rss))
- rss
+#' @rdname rss
+#' @method rss repArchetypes
+#'
+#' @S3method rss repArchetypes
+rss.repArchetypes <- function(object, ...) {
+ ret <- sapply(object, rss)
+ names(ret) <- paste('r', seq_along(ret), sep='')
+
+ return(ret)
}
-nparameters.step <- function(object, ...) {
- sapply(object, nparameters)[1]
+
+
+#' @rdname nparameters
+#' @method nparameters repArchetypes
+#'
+#' @S3method nparameters repArchetypes
+nparameters.repArchetypes <- function(object, ...) {
+ nparameters(object[[1]])
}
-bestModel.step <- function(object, reduced = TRUE, ...) {
- which <- which.min(rss(object))
- if ( length(which) == 0 )
- if ( reduced )
- return(NULL)
- else
- which <- 1
- subclass(list(object[[which]]), "step")
+#' @rdname bestModel
+#' @method bestModel repArchetypes
+#'
+#' @S3method bestModel repArchetypes
+bestModel.repArchetypes <- function(object, ...) {
+ m <- which.min(rss(object))
+
+ if ( length(m) == 0 )
+ return(object[[1]])
+ else
+ return(object[[m]])
}
-setMethod('parameters', signature = c(object = 'step'),
-function(object, ...) {
- lapply(object, parameters)
-})
-setMethod('profile', signature = c(fitted = 'step'),
-function(fitted, data, type = percentiles, ...) {
- lapply(fitted, profile, data, type)
-})
Modified: pkg/R/generics.R
===================================================================
--- pkg/R/generics.R 2012-04-26 12:57:43 UTC (rev 55)
+++ pkg/R/generics.R 2012-04-26 13:33:11 UTC (rev 56)
@@ -1,8 +1,7 @@
-#' Generic functions
+#' Defined generics
#'
-#' Generic functions defined by the archetypes package:
-#' Return residual sum of squares
+#' Generics defined by the archetypes package.
#'
#' @param object An object
#' @param ... Futher arguments
@@ -58,73 +57,3 @@
pcplot <- function(x, ...) {
UseMethod('pcplot')
}
-
-
-
-#' Scatter plot.
-#'
-#' @rdname archetypes-generics
-#'
-#' @export
-xyplot <- function(x, ...) {
- UseMethod('xyplot')
-}
-
-
-
-### Utility functions: ###############################################
-
-subclass <- function(x, subclass) {
- structure(x, class = c(subclass, class(x)))
-}
-
-
-
-## http://gettinggeneticsdone.blogspot.com/2010/03/arrange-multiple-ggplot2-plots-in-same.html
-vp.layout <- function(x, y) viewport(layout.pos.row=x, layout.pos.col=y)
-arrange <- function(..., nrow=NULL, ncol=NULL, as.table=FALSE) {
- dots <- list(...)
- n <- length(dots)
- if(is.null(nrow) & is.null(ncol)) { nrow = floor(n/2) ; ncol = ceiling(n/nrow)}
- if(is.null(nrow)) { nrow = ceiling(n/ncol)}
- if(is.null(ncol)) { ncol = ceiling(n/nrow)}
- ## NOTE see n2mfrow in grDevices for possible alternative
-grid.newpage()
-pushViewport(viewport(layout=grid.layout(nrow,ncol) ) )
- ii.p <- 1
- for(ii.row in seq(1, nrow)){
- ii.table.row <- ii.row
- if(as.table) {ii.table.row <- nrow - ii.table.row + 1}
- for(ii.col in seq(1, ncol)){
- ii.table <- ii.p
- if(ii.p > n) break
- print(dots[[ii.table]], vp=vp.layout(ii.table.row, ii.col))
- ii.p <- ii.p + 1
- }
- }
-}
-
-
-
-params_plot <- function(x, transpose = FALSE) {
- nullplot <- function(p) {
- if ( is.null(p) )
- NULL
- else
- plot(p)
- }
-
- plots <- lapply(unlist(x, recursive = FALSE), nullplot)
-
- dim <- c(ncol = max(sapply(x, length)),
- nrow = length(x))
-
- if ( transpose ) {
- dim <- rev(dim)
- order <- as.numeric(t(matrix(seq(along = plots), nrow = dim[2])))
- plots <- plots[order]
- }
-
- do.call(arrange, c(plots, list(nrow = dim[2], ncol = dim[1])))
-}
-
Modified: pkg/R/memento.R
===================================================================
--- pkg/R/memento.R 2012-04-26 12:57:43 UTC (rev 55)
+++ pkg/R/memento.R 2012-04-26 13:33:11 UTC (rev 56)
@@ -18,8 +18,7 @@
#' }
#' @aliases memento
#' @rdname memento
-#'
-#' @export
+#' @noRd
new.memento <- function() {
memento <- new.env(parent = emptyenv())
Deleted: pkg/R/panorama.R
===================================================================
--- pkg/R/panorama.R 2012-04-26 12:57:43 UTC (rev 55)
+++ pkg/R/panorama.R 2012-04-26 13:33:11 UTC (rev 56)
@@ -1,131 +0,0 @@
-#' @include generics.R
-{}
-
-
-
-#' Archetypes panorama
-#'
-#' @param object An \code{\link{archetypes}} object.
-#' @param data The corresponding data set.
-#' @param distfn The distance function; note that this function has to
-#' match with the archtypes blocks (see
-#' \code{\link{archetypesFamily}}).
-#' @param ordered Order the distances.
-#' @param ... Ignored.
-#'
-#' @return A list (class attribute \code{atypes_panorama}) with the
-#' distance matrix for each archetype and the data points and
-#' additional meta information.
-#'
-#' @method panorama archetypes
-#'
-#' @examples
-#' \dontrun{
-#' data(toy)
-#' a <- archetypes(toy, 3)
-#' plot(panorama(a, toy))
-#'
-#' ## See demo(robust-ozone).
-#' }
-#'
-#' @rdname panorama
-#'
-#' @S3method panorama archetypes
-panorama.archetypes <- function(object, data, distfn = distEuclidean,
- ordered = TRUE, ...) {
-
- n1 <- nrow(data)
- n2 <- nparameters(object)
-
- atypes <- parameters(object)
-
- data <- rbind(data, atypes)
- dist <- distfn(data, atypes)
-
- type <- c(rep("Data point", n1), rownames(atypes))
- type <- matrix(rep(type, n2), ncol = n2)
-
- order <- seq(length = n1)
- order <- matrix(rep(order, n2), ncol = n2)
-
- if ( ordered ) {
- order <- sapply(seq(length = n2), function(i) order(dist[, i]))
- dist <- sapply(seq(ncol(dist)), function(i) dist[order[, i], i])
- type <- sapply(seq(ncol(type)), function(i) type[order[, i], i])
- }
-
- colnames(dist) <- rownames(atypes)
- colnames(type) <- rownames(atypes)
- colnames(order) <- rownames(atypes)
-
- panorama <- list()
- panorama$dist <- dist
- panorama$type <- type
- panorama$order <- order
- panorama$ordered <- ordered
-
- class(panorama) <- c("atypes_panorama", class(panorama))
-
- panorama
-}
-
-
-
-#' @param x An \code{atypes_panorama} object.
-#' @rdname panorama
-#' @method xyplot atypes_panorama
-#' @S3method xyplot atypes_panorama
-xyplot.atypes_panorama <- function(x, ...) {
- x0 <- melt(x)
-
- x1 <- subset(x0, Archetype != "Data point")
- x1$Archetype <- x1$Archetype[, drop = TRUE]
-
- xlab <- {
- if ( x$ordered )
- "Index by distance"
- else
- "Index by observation"
- }
-
- p <- ggplot(x0, aes(X1, value))
- p <- p + geom_point() + facet_grid(X2 ~ .)
- p <- p + geom_point(data = x1, aes(colour = Archetype))
- p <- p + xlab(xlab) + ylab("Distance")
-
- p
-}
-
-
-
-#' @param y Ignored.
-#' @rdname panorama
-#' @method plot atypes_profile
-#' @S3method plot atypes_profile
-plot.atypes_panorama <- function(x, y = NULL, ...) {
- xyplot.atypes_panorama(x, ...)
-}
-
-
-
-distEuclidean <- function (x, centers) {
- if (ncol(x) != ncol(centers)) {
- stop(sQuote("x"), " and ", sQuote("centers"),
- " must have the same number of columns")
- }
-
- z <- matrix(0, nrow = nrow(x), ncol = nrow(centers))
- for (k in 1:nrow(centers)) {
- z[, k] <- sqrt(colSums((t(x) - centers[k, ])^2))
- }
- z
-}
-
-
-
-melt.atypes_panorama <- function(data, ...) {
- d <- melt(data$dist)
- d$Archetype <- melt(data$type)$value
- d
-}
-
Deleted: pkg/R/plot.R
===================================================================
--- pkg/R/plot.R 2012-04-26 12:57:43 UTC (rev 55)
+++ pkg/R/plot.R 2012-04-26 13:33:11 UTC (rev 56)
@@ -1,93 +0,0 @@
-#' @include generics.R
-{}
-
-
-
-xyplot.archetypes <- function(x, data = NULL, atypes.args = list(colour = "red"),
- chull = NULL,
- chull.args = list(colour = "gray"),
- ahull.show = FALSE, ahull.args = atypes.args,
- adata.show = FALSE, adata.args = list(colour = "green"),
- data.args = list(), ...) {
-
- atypes <- as.data.frame(parameters(x))
-
- stopifnot(ncol(atypes) == 2)
-
- xlab <- colnames(atypes)[1]
- ylab <- colnames(atypes)[2]
-
-
- ## Archetypes:
- p <- ggplot(atypes, aes_string(x = xlab, y = ylab))
-
-
- ## Data, convex hull:
- if ( !is.null(data) ) {
- data <- as.data.frame(data)
-
- p <- p + do.call(geom_point, c(list(data = data), data.args))
-
- if ( !is.null(chull) ) {
- chull <- data[c(chull, chull[1]), ]
-
- p <- p + do.call(geom_point, c(list(data = chull), chull.args))
- p <- p + do.call(geom_path, c(list(data = chull), chull.args))
- }
- }
-
-
- ## Approximated data:
- if ( adata.show ) {
- adata <- as.data.frame(fitted(x))
-
- p <- p + do.call(geom_point, c(list(data = adata), adata.args))
-
- if ( !is.null(data) ) {
- colnames(adata) <- sprintf("fitted.%s", colnames(adata))
-
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/archetypes -r 56
More information about the Archetypes-commits
mailing list