[Archetypes-commits] r51 - in pkg: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Oct 26 18:23:42 CEST 2011
Author: manuel
Date: 2011-10-26 18:23:41 +0200 (Wed, 26 Oct 2011)
New Revision: 51
Added:
pkg/R/panorama.R
pkg/R/profile.R
Removed:
pkg/R/archetypes-barplot.R
pkg/R/archetypes-panorama.R
Modified:
pkg/DESCRIPTION
pkg/NAMESPACE
pkg/NEWS
pkg/R/archetypes-class.R
pkg/R/generics.R
Log:
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2011-10-26 08:23:25 UTC (rev 50)
+++ pkg/DESCRIPTION 2011-10-26 16:23:41 UTC (rev 51)
@@ -24,13 +24,11 @@
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'
@@ -40,3 +38,5 @@
'archetypes-xyplot.R'
'memento.R'
'skeletonplot.R'
+ 'panorama.R'
+ 'profile.R'
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2011-10-26 08:23:25 UTC (rev 50)
+++ pkg/NAMESPACE 2011-10-26 16:23:41 UTC (rev 51)
@@ -17,15 +17,15 @@
export(weightedArchetypes)
export(xyplot)
exportMethods(parameters)
-importFrom(graphics,barplot)
+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,archetypes)
S3method(bestModel,repArchetypes)
S3method(bestModel,stepArchetypes)
S3method(coef,archetypes)
@@ -37,6 +37,8 @@
S3method(panorama,archetypes)
S3method(pcplot,archetypes)
S3method(pcplot,default)
+S3method(plot,atypes_panorama)
+S3method(plot,atypes_profile)
S3method(print,archetypes)
S3method(print,repArchetypes)
S3method(print,stepArchetypes)
Modified: pkg/NEWS
===================================================================
--- pkg/NEWS 2011-10-26 08:23:25 UTC (rev 50)
+++ pkg/NEWS 2011-10-26 16:23:41 UTC (rev 51)
@@ -1,7 +1,11 @@
Changes in archetypes version 2.1-0
- o Roxygen2-ified; added the Build-dep field to the DESCRIPTION
+ 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.
Deleted: pkg/R/archetypes-barplot.R
===================================================================
--- pkg/R/archetypes-barplot.R 2011-10-26 08:23:25 UTC (rev 50)
+++ pkg/R/archetypes-barplot.R 2011-10-26 16:23:41 UTC (rev 51)
@@ -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)
-}
-
Modified: pkg/R/archetypes-class.R
===================================================================
--- pkg/R/archetypes-class.R 2011-10-26 08:23:25 UTC (rev 50)
+++ pkg/R/archetypes-class.R 2011-10-26 16:23:41 UTC (rev 51)
@@ -35,6 +35,8 @@
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,
Deleted: pkg/R/archetypes-panorama.R
===================================================================
--- pkg/R/archetypes-panorama.R 2011-10-26 08:23:25 UTC (rev 50)
+++ pkg/R/archetypes-panorama.R 2011-10-26 16:23:41 UTC (rev 51)
@@ -1,106 +0,0 @@
-
-
-
-#' 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
-}
Modified: pkg/R/generics.R
===================================================================
--- pkg/R/generics.R 2011-10-26 08:23:25 UTC (rev 50)
+++ pkg/R/generics.R 2011-10-26 16:23:41 UTC (rev 51)
@@ -1,7 +1,8 @@
-#' Defined generics
+#' Generic functions
#'
-#' Generics defined by the archetypes package.
+#' Generic functions defined by the archetypes package:
+#' Return residual sum of squares
#'
#' @param object An object
#' @param ... Futher arguments
Added: pkg/R/panorama.R
===================================================================
--- pkg/R/panorama.R (rev 0)
+++ pkg/R/panorama.R 2011-10-26 16:23:41 UTC (rev 51)
@@ -0,0 +1,120 @@
+#' @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
+}
+
+
+
+#' @rdname panorama
+#' @method plot atypes_panorama
+#' @S3method plot atypes_panorama
+plot.atypes_panorama <- function(x, y = NULL, ...) {
+ 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
+}
+
+
+
+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
+}
+
Property changes on: pkg/R/panorama.R
___________________________________________________________________
Added: svn:keywords
+ Date Revision Author URL Id Header
Added: svn:eol-style
+ native
Added: pkg/R/profile.R
===================================================================
--- pkg/R/profile.R (rev 0)
+++ pkg/R/profile.R 2011-10-26 16:23:41 UTC (rev 51)
@@ -0,0 +1,67 @@
+
+
+#' Archetypes profile
+#'
+#' @param fitted An \code{\link{archetypes}} object.
+#' @param data The corresponding data set.
+#' @param type The profile function; currently only percentiles are
+#' supported.
+#'
+#' @return A matrix (with class attribute \code{atypes_profile}) with
+#' the computed profile.
+#'
+#' @aliases profile-methods
+#' @aliases profile,archetypes-method
+#'
+#' @examples
+#' \dontrun{
+#' data(toy)
+#' a <- archetypes(toy, 3)
+#' plot(profile(a, toy))
+#' }
+#'
+#' @usage
+#' \S4method{profile}{archetypes}(fitted, data, type = percentiles, ...)
+#'
+#' @importFrom stats profile
+#' @exportMethod profile
+setMethod("profile", signature = c(fitted = "archetypes"),
+function(fitted, data, type = percentiles, ...) {
+ stopifnot(!is.null(data))
+
+ profile <- parameters(fitted)
+ profile <- sapply(seq(length = ncol(data)),
+ function(i) percentiles(profile[, i], data[, i]))
+
+
+ rownames(profile) <- sprintf("Archetype %s", seq(length = nrow(profile)))
+ colnames(profile) <- colnames(data)
+
+ class(profile) <- c("atypes_profile", class(profile))
+
+
+ profile
+})
+
+
+
+percentiles <- function(x, data, digits = 0) {
+ Fn <- ecdf(data)
+ round(Fn(x) * 100, digits = digits)
+}
+
+
+
+#' @param x An \code{atypes_profile} object.
+#' @param y Ignored.
+#' @param ... Ignored.
+#' @rdname profile
+#' @method plot atypes_profile
+#' @S3method plot atypes_profile
+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
+}
+
Property changes on: pkg/R/profile.R
___________________________________________________________________
Added: svn:keywords
+ Date Revision Author URL Id Header
Added: svn:eol-style
+ native
More information about the Archetypes-commits
mailing list