[Archetypes-commits] r52 - in pkg: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Oct 28 17:07:32 CEST 2011
Author: manuel
Date: 2011-10-28 17:07:32 +0200 (Fri, 28 Oct 2011)
New Revision: 52
Removed:
pkg/R/archetypes-screeplot.R
Modified:
pkg/DESCRIPTION
pkg/NEWS
pkg/R/archetypes-class.R
pkg/R/archetypes-step.R
pkg/R/generics.R
pkg/R/profile.R
Log:
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2011-10-26 16:23:41 UTC (rev 51)
+++ pkg/DESCRIPTION 2011-10-28 15:07:32 UTC (rev 52)
@@ -7,20 +7,19 @@
methods,
stats,
modeltools,
- nnls (>= 1.1)
+ nnls (>= 1.1),
+ ggplot2
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: The main function archetypes implements a
- framework for archetypal analysis supporting arbitary
- problem solving mechanisms for the different conceputal
- parts of the algorithm.
+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:
@@ -40,3 +39,4 @@
'skeletonplot.R'
'panorama.R'
'profile.R'
+ 'parameters.R'
Modified: pkg/NEWS
===================================================================
--- pkg/NEWS 2011-10-26 16:23:41 UTC (rev 51)
+++ pkg/NEWS 2011-10-28 15:07:32 UTC (rev 52)
@@ -1,6 +1,9 @@
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.
Modified: pkg/R/archetypes-class.R
===================================================================
--- pkg/R/archetypes-class.R 2011-10-26 16:23:41 UTC (rev 51)
+++ pkg/R/archetypes-class.R 2011-10-28 15:07:32 UTC (rev 52)
@@ -35,8 +35,6 @@
family = NULL, familyArgs = NULL, residuals = NULL,
weights = NULL, reweights = NULL) {
- rownames(object) <- sprintf("Archetype %s", seq(length = k))
-
return(structure(list(archetypes = object,
k = k,
alphas = alphas,
@@ -91,38 +89,77 @@
-#' Return fitted archetypes
+#' Return coefficients
#'
#' @param object An \code{archetypes} object.
+#' @param type Return alpha or beta coefficients.
#' @param ... Ignored.
-#' @return Matrix with \eqn{k} archetypes.
+#' @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]]
+}
+
+
+
+#' 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, ...) {
- object$archetypes
+ parameters <- object$archetypes
+
+ if ( is.null(parameters) )
+ return(parameters)
+
+
+ rownames(parameters) <- sprintf("Archetype %s",
+ seq(length = object$k))
+
+ subclass(parameters, "atypes_parameters")
})
-#' Return coefficients
+#' @rdname parameters
+#' @method plot atypes_parameters
+#' @S3method plot atypes_parameters
+plot.atypes_parameters <- function(x, y = NULL, ...) {
+ p <- ggplot(melt(x), aes(X2, value))
+ p <- p + geom_bar(stat = "identity") + facet_grid(X1 ~ .)
+ p <- p + xlab("Variable") + ylab("Value")
+ p
+}
+
+
+
+#' Return number of archetypes
#'
#' @param object An \code{archetypes} object.
-#' @param type Return alpha or beta coefficients.
#' @param ... Ignored.
-#' @return Coefficient matrix.
-#' @method coef archetypes
-#' @rdname coef
+#' @return Number of archetypes.
+#' @rdname nparameters
#'
-#' @importFrom stats coef
-#' @S3method coef archetypes
-coef.archetypes <- function(object, type = c('alphas', 'betas'), ...) {
- type <- match.arg(type)
- object[[type]]
+#' @method nparameters archetypes
+#' @S3method nparameters archetypes
+nparameters.archetypes <- function(object, ...) {
+ return(object$k)
}
@@ -143,28 +180,6 @@
-#' 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.
@@ -199,17 +214,24 @@
-#' Return number of archetypes
+#' Return residual sum of squares
#'
#' @param object An \code{archetypes} object.
+#' @param type Return scaled, single or global RSS.
#' @param ... Ignored.
-#' @return Number of archetypes.
-#' @rdname nparameters
+#' @return Residual sum of squares.
+#' @method rss archetypes
+#' @rdname rss
#'
-#' @method nparameters archetypes
-#' @S3method nparameters archetypes
-nparameters.archetypes <- function(object, ...) {
- return(object$k)
+#' @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))
}
Deleted: pkg/R/archetypes-screeplot.R
===================================================================
--- pkg/R/archetypes-screeplot.R 2011-10-26 16:23:41 UTC (rev 51)
+++ pkg/R/archetypes-screeplot.R 2011-10-28 15:07:32 UTC (rev 52)
@@ -1,28 +0,0 @@
-
-
-#' 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 2011-10-26 16:23:41 UTC (rev 51)
+++ pkg/R/archetypes-step.R 2011-10-28 15:07:32 UTC (rev 52)
@@ -1,9 +1,14 @@
#' @include archetypes-class.R
+#' @include archetypes-rep.R
{}
#' 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}}.
@@ -14,12 +19,10 @@
#' \code{\link{robustArchetypes}},
#' @param verbose Show progress during exection.
#'
-#' @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.
+#' @return A list with \code{length(k)} elements and class attribute
+#' \code{stepArchetypes}.
#'
-#' @seealso \code{\link{archetypes}}
+#' @family archetypes
#'
#' @examples
#' \dontrun{
@@ -37,57 +40,33 @@
#'
#' @export
stepArchetypes <- function(..., k, nrep = 3, method = archetypes, verbose = TRUE) {
+ stopifnot(nrep > 0)
- mycall <- match.call()
as <- list()
+ as$call <- match.call()
+ as$nrep <- nrep
+ as$k <- k
+ as$models <- list()
- 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])
+ 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)
}
}
- return(structure(as, class='stepArchetypes', call=mycall))
+ subclass(as, "stepArchetypes")
}
-setOldClass('repArchetypes')
-setOldClass('stepArchetypes')
+setOldClass("stepArchetypes")
-#' Extract method
-#'
-#' An extraction on a \code{stepArchetypes} object returns again a
-#' \code{stepArchetypes} object.
-#'
-#' @param x A \code{stepArchetypes} object.
-#' @param i The indizes to extract.
-#' @return A \code{stepArchetypes} object containing only the parts
-#' defined in \code{i}.
-#' @method [ stepArchetypes
-#' @rdname extract
-#'
-#' @S3method "[" stepArchetypes
-`[.stepArchetypes` <- function(x, i) {
- y <- unclass(x)[i]
- attributes(y) <- attributes(x)
-
- return(y)
-}
-
-
-
#' @S3method print stepArchetypes
print.stepArchetypes <- function(x, ...) {
- cat('StepArchetypes object\n\n')
+ cat('stepArchetypes object\n\n')
cat(deparse(attr(x, 'call')), '\n')
}
@@ -116,23 +95,24 @@
-#' @aliases parameters,stepArchetypes-method
-#' @rdname parameters
-#' @importFrom modeltools parameters
-#' @exportMethod parameters
-setMethod('parameters', signature = c(object = 'stepArchetypes'),
-function(object, ...) {
- lapply(object, parameters)
-})
-
-
-
-#' @rdname nparameters
-#' @method nparameters stepArchetypes
+#' Extract method
#'
-#' @S3method nparameters stepArchetypes
-nparameters.stepArchetypes <- function(object, ...) {
- return(sapply(object, nparameters))
+#' An extraction on a \code{stepArchetypes} object returns again a
+#' \code{stepArchetypes} object.
+#'
+#' @param x A \code{stepArchetypes} object.
+#' @param i The indizes to extract.
+#' @return A \code{stepArchetypes} object containing only the parts
+#' defined in \code{i}.
+#' @method [ stepArchetypes
+#' @rdname extract
+#'
+#' @S3method "[" stepArchetypes
+`[.stepArchetypes` <- function(x, i) {
+ y <- unclass(x)[i]
+ attributes(y) <- attributes(x)
+
+ return(y)
}
@@ -142,13 +122,24 @@
#'
#' @S3method rss stepArchetypes
rss.stepArchetypes <- function(object, ...) {
- ret <- t(sapply(object, rss))
- rownames(ret) <- paste('k', nparameters(object), sep='')
- return(ret)
+ ret <- lapply(object$models, rss)
+ ret <- do.call(rbind, ret)
+ ret <- data.frame(Archetypes = nparameters(as), ret)
+ subclass(ret, "stepArchetypes_rss")
}
+plot.stepArchetypes_rss <- function(x, y = NULL, ...) {
+ p <- ggplot(melt(x, "Archetypes"),
+ aes(ordered(Archetypes), value, group = variable))
+ p <- p + geom_line()
+ p <- p + xlab("Number of archetypes") + ylab("RSS")
+ p
+}
+
+
+
#' Return best model
#'
#' @param object An \code{archetypes} object.
@@ -159,71 +150,51 @@
#'
#' @S3method bestModel stepArchetypes
bestModel.stepArchetypes <- function(object, ...) {
- zsmin <- lapply(object, bestModel)
-
- if ( length(zsmin) == 1 )
- return(zsmin[[1]])
- else
- return(zsmin)
+ object$models <- lapply(object$models, bestModel)
+ object$nrep <- 1
+ object
}
-#' @S3method print repArchetypes
-print.repArchetypes <- function(x, ...) {
- for ( i in seq_along(x) )
- print(x[[i]], ...)
-
- invisible(x)
-}
-
-
-
-#' @aliases parameters,repArchetypes-method
+#' @aliases parameters,stepArchetypes-method
#' @rdname parameters
#' @importFrom modeltools parameters
#' @exportMethod parameters
-setMethod('parameters', signature = signature(object = 'repArchetypes'),
+setMethod('parameters', signature = c(object = 'stepArchetypes'),
function(object, ...) {
- lapply(object, parameters)
+ subclass(lapply(object, parameters), "stepArchetypes_parameters")
})
-#' @rdname rss
-#' @method rss repArchetypes
+#' @rdname nparameters
+#' @method nparameters stepArchetypes
#'
-#' @S3method rss repArchetypes
-rss.repArchetypes <- function(object, ...) {
- ret <- sapply(object, rss)
- names(ret) <- paste('r', seq_along(ret), sep='')
-
- return(ret)
+#' @S3method nparameters stepArchetypes
+nparameters.stepArchetypes <- function(object, ...) {
+ return(sapply(object$model, nparameters))
}
-#' @rdname nparameters
-#' @method nparameters repArchetypes
-#'
-#' @S3method nparameters repArchetypes
-nparameters.repArchetypes <- function(object, ...) {
- nparameters(object[[1]])
+
+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
+}
+nparameters.step <- function(object, ...) {
+ sapply(object, nparameters)[1]
+}
-#' @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]])
+bestModel.step <- function(object, ...) {
+ which <- which.min(rss(object))
+ subclass(list(object[[which]]), "step")
}
-
Modified: pkg/R/generics.R
===================================================================
--- pkg/R/generics.R 2011-10-26 16:23:41 UTC (rev 51)
+++ pkg/R/generics.R 2011-10-28 15:07:32 UTC (rev 52)
@@ -58,3 +58,22 @@
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)))
+}
Modified: pkg/R/profile.R
===================================================================
--- pkg/R/profile.R 2011-10-26 16:23:41 UTC (rev 51)
+++ pkg/R/profile.R 2011-10-28 15:07:32 UTC (rev 52)
@@ -1,5 +1,10 @@
+#' @include archetypes-class.R
+#' @include archetypes-step.R
+#' @include archetypes-rep.R
+{}
+
#' Archetypes profile
#'
#' @param fitted An \code{\link{archetypes}} object.
@@ -33,6 +38,9 @@
profile <- sapply(seq(length = ncol(data)),
function(i) percentiles(profile[, i], data[, i]))
+ if ( !is.matrix(profile) ) {
+ profile <- t(as.matrix(profile))
+ }
rownames(profile) <- sprintf("Archetype %s", seq(length = nrow(profile)))
colnames(profile) <- colnames(data)
@@ -61,7 +69,7 @@
plot.atypes_profile <- function(x, y = NULL, ...) {
p <- ggplot(melt(x), aes(X2, value))
p <- p + geom_bar(stat = "identity") + facet_grid(X1 ~ .)
- p <- p + ylim(c(0, 100)) + xlab("Variables") + ylab("Percentile")
+ p <- p + ylim(c(0, 100)) + xlab("Variable") + ylab("Percentile")
p
}
More information about the Archetypes-commits
mailing list