From noreply at r-forge.r-project.org  Wed Apr  9 15:27:05 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed,  9 Apr 2014 15:27:05 +0200 (CEST)
Subject: [Archetypes-commits] r67 - in pkg: . R inst man
Message-ID: <20140409132706.0AFF81874DB@r-forge.r-project.org>

Author: manuel
Date: 2014-04-09 15:27:05 +0200 (Wed, 09 Apr 2014)
New Revision: 67

Added:
   pkg/R/simplex-pot.R
   pkg/man/simplexplot.Rd
Removed:
   pkg/inst/doc/
Modified:
   pkg/DESCRIPTION
   pkg/NAMESPACE
   pkg/NEWS
   pkg/R/archetypes-map.R
   pkg/R/generics.R
   pkg/inst/CITATION
   pkg/man/archmap.Rd
   pkg/man/parameters.Rd
   pkg/man/skeletonplot.Rd
Log:
simplexplot

Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION	2013-12-15 18:26:07 UTC (rev 66)
+++ pkg/DESCRIPTION	2014-04-09 13:27:05 UTC (rev 67)
@@ -1,8 +1,8 @@
 Package: archetypes
 Type: Package
 Title: Archetypal Analysis
-Version: 2.1-2
-Date: 2013-12-15
+Version: 2.2-0
+Date: 2014-04-08
 Depends:
     methods,
     stats,
@@ -14,9 +14,9 @@
     mlbench,
     ggplot2,
     TSP
-Authors at R: c(person("Manuel", "J. A. Eugster", role = c("aut", "cre"),
-    email = "manuel.eugster at stat.uni-muenchen.de"),
-    person("Friedrich", "Leisch", role = "aut"))
+Authors at R: c(person("Manuel", "J. A. Eugster", role = c("aut", "cre"), email =
+    "manuel at mjae.net"), person("Friedrich", "Leisch", role = "aut"),
+    person("Sohan", "Seth", role = "ctb"))
 Description: The main function archetypes implements a
     framework for archetypal analysis supporting arbitary
     problem solving mechanisms for the different conceputal
@@ -40,3 +40,4 @@
     'memento.R'
     'skeletonplot.R'
     'archetypes-map.R'
+    'simplex-pot.R'

Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE	2013-12-15 18:26:07 UTC (rev 66)
+++ pkg/NAMESPACE	2014-04-09 13:27:05 UTC (rev 67)
@@ -1,5 +1,31 @@
-import(nnls)
-import(methods)
+S3method("[",stepArchetypes)
+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(predict,archetypes)
+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,robustArchetypes)
+S3method(xyplot,stepArchetypes)
+S3method(xyplot,weightedArchetypes)
 export(archetypes)
 export(archetypesFamily)
 export(archmap)
@@ -16,6 +42,7 @@
 export(robustArchetypes)
 export(rss)
 export(simplex_projection)
+export(simplexplot)
 export(skeletonplot)
 export(stepArchetypes)
 export(tspsimplex_projection)
@@ -29,31 +56,3 @@
 importFrom(stats,residuals)
 importFrom(stats,screeplot)
 importFrom(stats,weights)
-S3method("[",stepArchetypes)
-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(predict,archetypes)
-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,robustArchetypes)
-S3method(xyplot,stepArchetypes)
-S3method(xyplot,weightedArchetypes)

Modified: pkg/NEWS
===================================================================
--- pkg/NEWS	2013-12-15 18:26:07 UTC (rev 66)
+++ pkg/NEWS	2014-04-09 13:27:05 UTC (rev 67)
@@ -1,4 +1,11 @@
 
+Changes in archetypes version 2.2-0
+
+  o Added simplex plot with examples and reference.
+
+  o Updated weighted and robust archetypes reference.
+
+
 Changes in archetypes version 2.1-2
 
   o Moved vignette to 'vignettes' directory.

Modified: pkg/R/archetypes-map.R
===================================================================
--- pkg/R/archetypes-map.R	2013-12-15 18:26:07 UTC (rev 66)
+++ pkg/R/archetypes-map.R	2014-04-09 13:27:05 UTC (rev 67)
@@ -23,6 +23,7 @@
 #'   Invisible matrix with the projected archetypes
 #'
 #' @examples
+#' \dontrun{
 #'   data("skel", package = "archetypes")
 #'   skel2 <- subset(skel, select = -Gender)
 #'
@@ -43,6 +44,7 @@
 #'   ## MDS projection:
 #'   archmap(a, col = skel$Gender,
 #'           projection = atypes_projection)
+#' }
 #'
 #' @family archmap
 #'
@@ -51,6 +53,8 @@
                     projection_args = list(), rotate = 0,
                     cex = 1.5, col = 1, pch = 1, xlab = "", ylab = "",
                     axes = FALSE, asp = TRUE, ...) {
+    
+    .Deprecated("simplexplot", old = "archmap")
 
     stopifnot("archetypes" %in% class(object))
     stopifnot(is.function(projection))

Modified: pkg/R/generics.R
===================================================================
--- pkg/R/generics.R	2013-12-15 18:26:07 UTC (rev 66)
+++ pkg/R/generics.R	2014-04-09 13:27:05 UTC (rev 67)
@@ -51,9 +51,10 @@
 #' Parallel coordinates plot
 #'
 #' @param x An object.
-#' @rdname archetypes-generics
+#' @rdname archetypes-generics 
 #'
 #' @export
 pcplot <- function(x, ...) {
   UseMethod('pcplot')
 }
+

Added: pkg/R/simplex-pot.R
===================================================================
--- pkg/R/simplex-pot.R	                        (rev 0)
+++ pkg/R/simplex-pot.R	2014-04-09 13:27:05 UTC (rev 67)
@@ -0,0 +1,190 @@
+#' @include archetypes-map.R
+{}
+
+
+#' Simplex visualization
+#' 
+#' The stochastic nature of the alpha coefficients implies that they 
+#' exist on a standard (K-1)-simplex with the K archetypes Z as the
+#' corners, and the coefficients as the coordinate with respect to these
+#' corners. A standard simplex can be projected to two dimensions via 
+#' a skew orthogonal projection, where all the vertices of the simplex
+#' are shown on a circle connected by edges. The individual alpha 
+#' coefficients can be then projected into this circle.
+#' 
+#' @param object An \code{\link{archetypes}} object
+#' @param radius Radius of the projection
+#' @param order Order of the archetypes
+#' @param labels_cex Label expansion
+#' @param labels Labels
+#' @param show_labels Show labels
+#' @param points_col Color of the points
+#' @param points_pch Plot character of the points
+#' @param points_cex Character expansion of the points
+#' @param projection Projection function; see 
+#'   \code{\link{archmap_projections}}
+#' @param show_points Show the points
+#' @param show_circle Show the circle
+#' @param circle_col Color of the circle
+#' @param show_edges Show the edges
+#' @param edges_col Color of the edges
+#' @param direction_length Expansion of the direction pointers
+#' @param directions_col Color of the direction pointers
+#' @param show_direction Show direction pointers
+#' @param ... Additional arguments; currently ignored 
+#'
+#' @return
+#'   Invisible list of all computed components needed for the simplex
+#'   visualization.
+#'   
+#' @examples
+#'   ### This example reproduces parts of the Figure 7 shown in 
+#'   ### "Probabilistic Archetypal Analysis" by Seth and Eugster (2014)
+#' 
+#'   data("toy", package = "archetypes")
+#'   
+#'   set.seed(1234); a3 <- archetypes(toy, k = 3)
+#'   set.seed(1237); a4 <- archetypes(toy, k = 4)
+#'   set.seed(1238); a5 <- archetypes(toy, k = 5)
+#'   
+#'   simplexplot(a3)
+#'   simplexplot(a3, show_direction = TRUE, show_points = FALSE)
+#'   simplexplot(a4, projection = tspsimplex_projection)
+#'   simplexplot(a5, show_direction = TRUE, show_points = FALSE, 
+#'     direction_length = 2, directions_col = "black")
+#'
+#' @references
+#'   See Section 6 in "Probabilistic Archetypal Analysis" by Seth and 
+#'   Eugster (2014), http://arxiv.org/abs/1312.7604.   
+#' 
+#' @family simplexplot
+#' 
+#' @export
+simplexplot <- function(object, radius = 10, order = NULL,
+                        labels_cex = 1, labels = NULL, show_labels = TRUE,
+                        points_col = "#00000044", points_pch = 19, points_cex = 1,
+                        projection = simplex_projection, show_points = TRUE,
+                        show_circle = TRUE, circle_col = "lightgray",
+                        show_edges = TRUE, edges_col = "lightgray",
+                        show_direction = FALSE,
+                        direction_length = 1, directions_col = points_col, ...) {
+  
+  stopifnot("archetypes" %in% class(object))
+  stopifnot(is.function(projection))
+  
+  k <- object$k
+  
+  if ( is.null(order) ) 
+    order <- 1:k
+  
+  if ( is.null(labels) )
+    labels <- sprintf("A%s", order)
+  
+  if ( length(points_col) == 1 )
+    points_col <- rep(points_col, nrow(coef(object)))
+  
+  if ( length(points_cex) == 1 )
+    points_cex <- rep(points_cex, nrow(coef(object)))
+  
+  if ( length(directions_col) == 1)
+    directions_col <- rep(directions_col, nrow(coef(object)))
+  
+  
+  params <- parameters(object)[order, ]
+  coefs <- coef(object)[, order]
+  
+  
+  proj_z <- projection(params, r = radius - 1)
+  proj_h <- coefs %*% proj_z
+  
+  proj_labels <- proj_z
+  t <- cbind(x = acos(proj_z[, "x"] / (radius-1)), y = asin(proj_z[, "y"] / (radius-1)))
+  proj_labels <- cbind(x = radius * cos(t[, "x"]), y = radius * sin(t[, "y"]))
+  
+  proj_circle <- list(center = cbind(x = 0, y = 0), radius = radius - 1)
+  proj_edges <- proj_z[as.integer(combn(1:k, 2)), ]
+  
+  proj_directions <- vector("list", length = nrow(object$alphas))
+
+  for ( j in 1:nrow(object$alphas)) {
+    s <- proj_h[j, , drop = FALSE]
+    d <- matrix(NA_real_, ncol = 2, nrow = ncol(object$alphas))
+    for ( i in 1:ncol(object$alphas) ) {  
+      e <- proj_z[i, , drop = FALSE]
+      
+      v <- e - s
+      m <- sqrt(sum(v^2))
+      v <- v / m
+
+      px <- s[1] + v[1] * direction_length * object$alphas[j, i]
+      py <- s[2] + v[2] * direction_length * object$alphas[j, i]
+      
+      d[i, ] <- c(px, py)
+    }
+    proj_directions[[j]] <- list(s = s, e = d)
+  }
+  
+  
+  ### Plot:
+  plot(proj_z, type = "n", asp = TRUE, 
+       xlim = c(-radius, radius), ylim = c(-radius, radius),
+       axes = FALSE, xlab = "", ylab = "")
+  
+  if ( show_circle ) {
+    symbols(proj_circle$center, circles = radius - 1, 
+            inches = FALSE, add = TRUE, asp = TRUE, fg = circle_col)
+  }
+  
+  if ( show_edges ) {
+    lines(proj_edges, col = edges_col)
+  }
+  
+  if ( show_labels ) {
+    text(proj_labels, labels = labels, cex = labels_cex)
+  }
+  
+  if ( show_direction ) {
+    for ( d in proj_directions ) {
+      for ( i in 1:nrow(d$e) ) {
+        lines(rbind(d$s, d$e[i, ,drop = FALSE]), col = directions_col) #[j])
+      }
+    }
+  }
+  
+  if ( show_points ) {
+    points(proj_h, col = points_col, pch = points_pch, cex = points_cex)
+  }
+  
+  
+  ret <- list(proj_z = proj_z, proj_h = proj_h, proj_labels = proj_labels,
+              proj_directions = proj_directions, proj_circle = proj_circle,
+              proj_edges = proj_edges)
+  class(ret) <- "simplexplot"
+ 
+  
+  invisible(ret)
+}
+
+
+
+### Deviance: ########################################################
+
+gaussian_deviance <- function(object, data) {
+  y <- object$alphas %*% object$archetypes  
+  sqrt(rowSums((y - data)^2))  
+}
+
+
+poission_deviance <- function(object, data) {
+  t <- object$alphas %*% object$archetypes
+  rowSums(2 * (data * log((data +.Machine$double.eps)/t) - data + t))
+}
+
+
+bernoulli_deviance <- function(object, data) {
+  t <- object$alphas %*% object$archetypes
+  t[t > 1] <- 1.0
+  rowSums(2 * (data * log((data +.Machine$double.eps)/(t+.Machine$double.eps)) + 
+                 (1-data) * log(((1-data) +.Machine$double.eps)/(1-t+.Machine$double.eps))))
+}
+

Modified: pkg/inst/CITATION
===================================================================
--- pkg/inst/CITATION	2013-12-15 18:26:07 UTC (rev 66)
+++ pkg/inst/CITATION	2014-04-09 13:27:05 UTC (rev 67)
@@ -1,39 +1,58 @@
-
-citEntry(entry="Article",
-	title="{From {S}pider-{M}an to {H}ero -- Archetypal Analsis in {R}",
-	author=personList(as.person("Manuel J. A. Eugster"),
-		as.person("Friedrich Leisch")),
-	journal="Journal of Statistical Software",
-	year="2009",
-	volume="30",
-	number="8",
-	pages="1--23",
-	url="http://www.jstatsoft.org/v30/i08/",
-
-	header="To cite package archetypes in publications use:",
-	
-	textVersion=paste("Manuel J. A. Eugster and Friedrich Leisch.",
-		"From Spider-Man to Hero -- Archetypal Analysis in R.",
-		"Journal of Statistical Software, 30(8), 1-23, 2009.",
-		"http://www.jstatsoft.org/v30/i08/")
-)
-
-
-citEntry(entry="Article",
-	title="Weighted and Robust Archetypal Analysis",
-	author=personList(as.person("Manuel J. A. Eugster"),
-		as.person("Friedrich Leisch")),
-	journal="Technical Report 82, Department of Statistics, Ludwig-Maximilians-Universitaet Muenchen, Germany",
-	year="2010",
-	volume="82",
-	pages="1--13",
-	url="http://epub.ub.uni-muenchen.de/11498/",
-
-	header="To cite weighted and robust archetypes in publications use:",
-	
-	textVersion=paste("Manuel J. A. Eugster and Friedrich Leisch.",
-		"Weighted and Robust Archetypal Analysis",
-		"Technical Report 82, Department of Statistics, Ludwig-Maximilians-Universitaet Muenchen, Germany. 2010.",
-		"http://epub.ub.uni-muenchen.de/11498/")
-)
-
+
+citEntry(entry="Article",
+	title="{From {S}pider-{M}an to {H}ero -- Archetypal Analsis in {R}",
+	author=personList(as.person("Manuel J. A. Eugster"),
+		as.person("Friedrich Leisch")),
+	journal="Journal of Statistical Software",
+	year="2009",
+	volume="30",
+	number="8",
+	pages="1--23",
+	url="http://www.jstatsoft.org/v30/i08/",
+
+	header="To cite package archetypes in publications use:",
+	
+	textVersion=paste("Manuel J. A. Eugster and Friedrich Leisch.",
+		"From Spider-Man to Hero -- Archetypal Analysis in R.",
+		"Journal of Statistical Software, 30(8), 1-23, 2009.",
+		"http://www.jstatsoft.org/v30/i08/")
+)
+
+
+citEntry(entry="Article",
+	title="Weighted and Robust Archetypal Analysis",
+	author=personList(as.person("Manuel J. A. Eugster"),
+		as.person("Friedrich Leisch")),
+  journal="Computational Statistics and Data Analysis",
+  year = "2011",
+  volume = "55",
+  number = "3",
+  pages = "1215--1225",
+  url = "http://www.sciencedirect.com/science/article/pii/S0167947310004056",
+  preprint = "http://epub.ub.uni-muenchen.de/11498/",
+
+	header="To cite weighted and robust archetypes in publications use:",
+	
+	textVersion=paste("Manuel J. A. Eugster and Friedrich Leisch.",
+		"Weighted and Robust Archetypal Analysis",
+    "Computational Statistics and Data Analysis, 55(3):1215-1225, 2011.",
+		"http://www.sciencedirect.com/science/article/pii/S0167947310004056")
+)
+
+
+citEntry(entry="TechReport",
+  title="Probabilistic Archetypal Analysis",
+	author=personList(as.person("Sohan Seth"),
+    as.person("Manuel J. A. Eugster")),
+  institution="arXiv.org",
+  year = "2014",
+  url = "http://arxiv.org/abs/1312.7604",
+
+	header="To cite the simplex visualization in publications use:",
+	
+	textVersion=paste("Sohan Seth and Manuel J. A. Eugster.",
+		" Probabilistic Archetypal Analysis",
+    "arXiv.org, 2014.",
+		"http://arxiv.org/abs/1312.7604")
+)
+

Modified: pkg/man/archmap.Rd
===================================================================
--- pkg/man/archmap.Rd	2013-12-15 18:26:07 UTC (rev 66)
+++ pkg/man/archmap.Rd	2014-04-09 13:27:05 UTC (rev 67)
@@ -44,7 +44,8 @@
   (projected) archetypes.
 }
 \examples{
-data("skel", package = "archetypes")
+\dontrun{
+  data("skel", package = "archetypes")
   skel2 <- subset(skel, select = -Gender)
 
   set.seed(1981)
@@ -65,6 +66,7 @@
   archmap(a, col = skel$Gender,
           projection = atypes_projection)
 }
+}
 \seealso{
   Other archmap: \code{\link{atypes_projection}},
   \code{\link{simplex_projection}},

Modified: pkg/man/parameters.Rd
===================================================================
--- pkg/man/parameters.Rd	2013-12-15 18:26:07 UTC (rev 66)
+++ pkg/man/parameters.Rd	2014-04-09 13:27:05 UTC (rev 67)
@@ -1,19 +1,19 @@
-\name{parameters}
-\alias{parameters}
-\alias{parameters-methods}
-\alias{parameters,archetypes-method}
-\alias{parameters,repArchetypes-method}
-\alias{parameters,stepArchetypes-method}
-\title{Return fitted archetypes}
-\arguments{
-  \item{object}{An \code{archetypes} object.}
-
-  \item{...}{Ignored.}
-}
-\value{
-  Matrix with \eqn{k} archetypes.
-}
-\description{
-  Return fitted archetypes
-}
-
+\name{parameters}
+\alias{parameters}
+\alias{parameters,archetypes-method}
+\alias{parameters,repArchetypes-method}
+\alias{parameters,stepArchetypes-method}
+\alias{parameters-methods}
+\title{Return fitted archetypes}
+\arguments{
+  \item{object}{An \code{archetypes} object.}
+
+  \item{...}{Ignored.}
+}
+\value{
+  Matrix with \eqn{k} archetypes.
+}
+\description{
+  Return fitted archetypes
+}
+

Added: pkg/man/simplexplot.Rd
===================================================================
--- pkg/man/simplexplot.Rd	                        (rev 0)
+++ pkg/man/simplexplot.Rd	2014-04-09 13:27:05 UTC (rev 67)
@@ -0,0 +1,90 @@
+\name{simplexplot}
+\alias{simplexplot}
+\title{Simplex visualization}
+\usage{
+  simplexplot(object, radius = 10, order = NULL,
+    labels_cex = 1, labels = NULL, show_labels = TRUE,
+    points_col = "#00000044", points_pch = 19,
+    points_cex = 1, projection = simplex_projection,
+    show_points = TRUE, show_circle = TRUE,
+    circle_col = "lightgray", show_edges = TRUE,
+    edges_col = "lightgray", show_direction = FALSE,
+    direction_length = 1, directions_col = points_col, ...)
+}
+\arguments{
+  \item{object}{An \code{\link{archetypes}} object}
+
+  \item{radius}{Radius of the projection}
+
+  \item{order}{Order of the archetypes}
+
+  \item{labels_cex}{Label expansion}
+
+  \item{labels}{Labels}
+
+  \item{show_labels}{Show labels}
+
+  \item{points_col}{Color of the points}
+
+  \item{points_pch}{Plot character of the points}
+
+  \item{points_cex}{Character expansion of the points}
+
+  \item{projection}{Projection function; see
+  \code{\link{archmap_projections}}}
+
+  \item{show_points}{Show the points}
+
+  \item{show_circle}{Show the circle}
+
+  \item{circle_col}{Color of the circle}
+
+  \item{show_edges}{Show the edges}
+
+  \item{edges_col}{Color of the edges}
+
+  \item{direction_length}{Expansion of the direction
+  pointers}
+
+  \item{directions_col}{Color of the direction pointers}
+
+  \item{show_direction}{Show direction pointers}
+
+  \item{...}{Additional arguments; currently ignored}
+}
+\value{
+  Invisible list of all computed components needed for the
+  simplex visualization.
+}
+\description{
+  The stochastic nature of the alpha coefficients implies
+  that they exist on a standard (K-1)-simplex with the K
+  archetypes Z as the corners, and the coefficients as the
+  coordinate with respect to these corners. A standard
+  simplex can be projected to two dimensions via a skew
+  orthogonal projection, where all the vertices of the
+  simplex are shown on a circle connected by edges. The
+  individual alpha coefficients can be then projected into
+  this circle.
+}
+\examples{
+### This example reproduces parts of the Figure 7 shown in
+  ### "Probabilistic Archetypal Analysis" by Seth and Eugster (2014)
+
+  data("toy", package = "archetypes")
+
+  set.seed(1234); a3 <- archetypes(toy, k = 3)
+  set.seed(1237); a4 <- archetypes(toy, k = 4)
+  set.seed(1238); a5 <- archetypes(toy, k = 5)
+
+  simplexplot(a3)
+  simplexplot(a3, show_direction = TRUE, show_points = FALSE)
+  simplexplot(a4, projection = tspsimplex_projection)
+  simplexplot(a5, show_direction = TRUE, show_points = FALSE,
+    direction_length = 2, directions_col = "black")
+}
+\references{
+  See Section 6 in "Probabilistic Archetypal Analysis" by
+  Seth and Eugster (2014), http://arxiv.org/abs/1312.7604.
+}
+

Modified: pkg/man/skeletonplot.Rd
===================================================================
--- pkg/man/skeletonplot.Rd	2013-12-15 18:26:07 UTC (rev 66)
+++ pkg/man/skeletonplot.Rd	2014-04-09 13:27:05 UTC (rev 67)
@@ -7,9 +7,8 @@
     ylab = "Height (cm)", base.radius = 2, xlab = "",
     xlim = (nrow(x) * c(0, skel.width)),
     ylim = c(0, skel.height),
-    col = c(hipbase = 1, hip = 1, shoulderbase = 1, shoulder = 1,
-    head = 1, elbow = 2, wrist = 3, knee = 4, ankle = 5, chest = "purple1",
-    pelvis = 6), mtext = TRUE, skel.lwd = 1, ...)
+    col = c(hipbase = 1, hip = 1, shoulderbase = 1, shoulder = 1, head = 1, elbow = 2, wrist = 3, knee = 4, ankle = 5, chest = "purple1", pelvis = 6),
+    mtext = TRUE, skel.lwd = 1, ...)
 
   jd()
 }


From noreply at r-forge.r-project.org  Wed Apr  9 16:57:31 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed,  9 Apr 2014 16:57:31 +0200 (CEST)
Subject: [Archetypes-commits] r68 - in pkg: . R man
Message-ID: <20140409145731.54E25186F4F@r-forge.r-project.org>

Author: manuel
Date: 2014-04-09 16:57:30 +0200 (Wed, 09 Apr 2014)
New Revision: 68

Modified:
   pkg/DESCRIPTION
   pkg/NAMESPACE
   pkg/R/archetypes-class.R
   pkg/R/archetypes-kit-blocks.R
   pkg/R/archetypes-step.R
   pkg/R/skeletonplot.R
   pkg/man/archetypes-generics.Rd
   pkg/man/archetypes.Rd
   pkg/man/archetypesFamily.Rd
   pkg/man/archmap.Rd
   pkg/man/archmap_projections.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/predict.Rd
   pkg/man/residuals.Rd
   pkg/man/robustArchetypes.Rd
   pkg/man/rss.Rd
   pkg/man/screeplot.stepArchetypes.Rd
   pkg/man/simplexplot.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
Log:
sp

Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION	2014-04-09 13:27:05 UTC (rev 67)
+++ pkg/DESCRIPTION	2014-04-09 14:57:30 UTC (rev 68)
@@ -28,6 +28,7 @@
     'archetypes-class.R'
     'archetypes-kit-blocks.R'
     'archetypes-kit.R'
+    'archetypes-map.R'
     'archetypes-movie.R'
     'archetypes-panorama.R'
     'pcplot.R'
@@ -38,6 +39,5 @@
     'archetypes-weighted.R'
     'archetypes-xyplot.R'
     'memento.R'
+    'simplex-pot.R'
     'skeletonplot.R'
-    'archetypes-map.R'
-    'simplex-pot.R'

Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE	2014-04-09 13:27:05 UTC (rev 67)
+++ pkg/NAMESPACE	2014-04-09 14:57:30 UTC (rev 68)
@@ -49,6 +49,8 @@
 export(weightedArchetypes)
 export(xyplot)
 exportMethods(parameters)
+import(methods)
+import(nnls)
 importFrom(graphics,barplot)
 importFrom(modeltools,parameters)
 importFrom(stats,coef)

Modified: pkg/R/archetypes-class.R
===================================================================
--- pkg/R/archetypes-class.R	2014-04-09 13:27:05 UTC (rev 67)
+++ pkg/R/archetypes-class.R	2014-04-09 14:57:30 UTC (rev 68)
@@ -1,251 +1,253 @@
-#' @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.
-#' @param scaling The scaling parameters of the data.
-#'
-#' @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, scaling = 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,
-                        scaling = scaling),
-                   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 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.
-#' @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 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 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.
-#' @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 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)
-}
-
-
-
-#' Predict method for archetypal analysis fits
-#'
-#' This method produces predicted alpha coefficients for new data.
-#'
-#' @param object An \code{archetypes} object; currently only
-#'   \code{\link[=archetypesFamily]{original}}-family objects.
-#' @param newdata A data frame with data for which to
-#'   predict the alpha coefficients.
-#' @param ... Ignored.
-#' @return The predict alpha coefficients.
-#' @rdname predict
-#'
-#' @method predict archetypes
-#' @S3method predict archetypes
-predict.archetypes <- function(object, newdata, ...) {
-  stopifnot(object$family$which == "original")
-
-  scale <- object$scaling
-
-  ## HACK: use blocks!
-  x <- t(newdata)
-  x <- x - scale$mean
-  x <- x / scale$sd
-  x <- object$family$dummyfn(x, ...)
-
-  zs <- t(parameters(object))
-  zs <- zs - scale$mean
-  zs <- zs / scale$sd
-  zs <- rbind(zs, 200)
-
-  alphas <- matrix(NA, ncol = ncol(x), nrow = ncol(coef(object)))
-  alphas <- object$family$alphasfn(alphas, zs, x)
-
-  t(alphas)
-}
+#' @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.
+#' @param scaling The scaling parameters of the data.
+#'
+#' @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, scaling = 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,
+                        scaling = scaling),
+                   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 fitted archetypes
+#'
+#' @param object An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return Matrix with \eqn{k} archetypes.
+#'
+#' @aliases parameters-methods
+#' @aliases parameters,archetypes-method
+#'
+#' @import methods
+#' @importFrom modeltools parameters
+#' @exportMethod parameters
+#' @rdname parameters
+setMethod('parameters', signature = c(object = 'archetypes'),
+function(object, ...) { 
+  object$archetypes
+})
+
+
+
+#' 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 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 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.
+#' @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 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)
+}
+
+
+
+#' Predict method for archetypal analysis fits
+#'
+#' This method produces predicted alpha coefficients for new data.
+#'
+#' @param object An \code{archetypes} object; currently only
+#'   \code{\link[=archetypesFamily]{original}}-family objects.
+#' @param newdata A data frame with data for which to
+#'   predict the alpha coefficients.
+#' @param ... Ignored.
+#' @return The predict alpha coefficients.
+#' @rdname predict
+#'
+#' @method predict archetypes
+#' @S3method predict archetypes
+predict.archetypes <- function(object, newdata, ...) {
+  stopifnot(object$family$which == "original")
+
+  scale <- object$scaling
+
+  ## HACK: use blocks!
+  x <- t(newdata)
+  x <- x - scale$mean
+  x <- x / scale$sd
+  x <- object$family$dummyfn(x, ...)
+
+  zs <- t(parameters(object))
+  zs <- zs - scale$mean
+  zs <- zs / scale$sd
+  zs <- rbind(zs, 200)
+
+  alphas <- matrix(NA, ncol = ncol(x), nrow = ncol(coef(object)))
+  alphas <- object$family$alphasfn(alphas, zs, x)
+
+  t(alphas)
+}

Modified: pkg/R/archetypes-kit-blocks.R
===================================================================
--- pkg/R/archetypes-kit-blocks.R	2014-04-09 13:27:05 UTC (rev 67)
+++ pkg/R/archetypes-kit-blocks.R	2014-04-09 14:57:30 UTC (rev 68)
@@ -168,6 +168,7 @@
 #' @param C The archetypes matrix.
 #' @param d The data matrix.
 #' @return Recalculated alpha.
+#' @import nnls
 #' @noRd
 nnls.alphasfn <- function(coefs, C, d, ...) {
   #require(nnls)
@@ -185,6 +186,7 @@
 #' @param C The archetypes matrix.
 #' @param d The data matrix.
 #' @return Recalculated alpha.
+#' @import nnls
 #' @noRd
 snnls.alphasfn <- function(coefs, C, d, ...) {
   #require(nnls)
@@ -214,6 +216,7 @@
 #' @param C The data matrix.
 #' @param d The archetypes matrix.
 #' @return Recalculated beta.
+#' @import nnls
 #' @noRd
 nnls.betasfn <- nnls.alphasfn
 
@@ -224,6 +227,7 @@
 #' @param C The data matrix.
 #' @param d The archetypes matrix.
 #' @return Recalculated beta.
+#' @import nnls
 #' @noRd
 snnls.betasfn <- snnls.alphasfn
 

Modified: pkg/R/archetypes-step.R
===================================================================
--- pkg/R/archetypes-step.R	2014-04-09 13:27:05 UTC (rev 67)
+++ pkg/R/archetypes-step.R	2014-04-09 14:57:30 UTC (rev 68)
@@ -1,229 +1,230 @@
-#' @include archetypes-class.R
-{}
-
-
-#' Run archetypes algorithm repeatedly
-#'
-#' @param ... Passed to the specific archetype function.
-#' @param k A vector of integers passed in turn to the k argument of
-#'   \code{\link{archetypes}}.
-#' @param nrep For each value of \code{k} run \code{\link{archetypes}}
-#'   \code{nrep} times.
-#' @param method Archetypes function to use, typically
-#'   \code{\link{archetypes}}, \code{\link{weightedArchetypes}} or
-#'   \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.
-#'
-#' @seealso \code{\link{archetypes}}
-#'
-#' @examples
-#'   \dontrun{
-#'   data(skel)
-#'   skel2 <- subset(skel, select=-Gender)
-#'   as <- stepArchetypes(skel2, k=1:5, verbose=FALSE)
-#'
-#'   ## Residual sum of squares curve:
-#'   screeplot(as)
-#'
-#'   ## Select three archetypes and from that the best
-#'   ## recurrence:
-#'   a3 <- bestModel(as[[3]])
-#'   }
-#'
-#' @export
-stepArchetypes <- function(..., k, nrep = 3, method = archetypes, verbose = TRUE) {
-
-  mycall <- match.call()
-  as <- 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])
-    }
-  }
-
-  return(structure(as, class='stepArchetypes', call=mycall))
-}
-
-
-
-setOldClass('repArchetypes')
-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(deparse(attr(x, 'call')), '\n')
-}
-
-
-
-#' Summary method for stepArchetypes object
-#'
-#' @param object A \code{stepArchetypes} object.
-#' @param ... Ignored.
-#' @return Undefined.
-#'
-#' @method summary stepArchetypes
-#' @rdname summary
-#'
-#' @S3method summary stepArchetypes
-summary.stepArchetypes <- function(object, ...) {
-  print(object)
-
-  ps <- nparameters(object)
-
-  for ( i in seq_along(object) ) {
-    cat('\nk=', ps[i], ':\n', sep='')
-    print(object[[i]], full=FALSE)
-  }
-}
-
-
-
-#' @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
-#'
-#' @S3method nparameters stepArchetypes
-nparameters.stepArchetypes <- function(object, ...) {
-  return(sapply(object, nparameters))
-}
-
-
-
-#' @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)
-}
-
-
-
-#' 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)
-}
-
-
-
-#' @S3method print repArchetypes
-print.repArchetypes <- function(x, ...) {
-  for ( i in seq_along(x) )
-    print(x[[i]], ...)
-
-  invisible(x)
-}
-
-
-
-#' @aliases parameters,repArchetypes-method
-#' @rdname parameters
-#' @importFrom modeltools parameters
-#' @exportMethod parameters
-setMethod('parameters', signature = signature(object = 'repArchetypes'),
-function(object, ...) {
-  lapply(object, parameters)
-})
-
-
-
-#' @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)
-}
-
-
-
-#' @rdname nparameters
-#' @method nparameters repArchetypes
-#'
-#' @S3method nparameters repArchetypes
-nparameters.repArchetypes <- function(object, ...) {
-  nparameters(object[[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]])
-}
-
-
+#' @include archetypes-class.R
+{}
+
+
+#' Run archetypes algorithm repeatedly
+#'
+#' @param ... Passed to the specific archetype function.
+#' @param k A vector of integers passed in turn to the k argument of
+#'   \code{\link{archetypes}}.
+#' @param nrep For each value of \code{k} run \code{\link{archetypes}}
+#'   \code{nrep} times.
+#' @param method Archetypes function to use, typically
+#'   \code{\link{archetypes}}, \code{\link{weightedArchetypes}} or
+#'   \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.
+#'
+#' @seealso \code{\link{archetypes}}
+#'
+#' @examples
+#'   \dontrun{
+#'   data(skel)
+#'   skel2 <- subset(skel, select=-Gender)
+#'   as <- stepArchetypes(skel2, k=1:5, verbose=FALSE)
+#'
+#'   ## Residual sum of squares curve:
+#'   screeplot(as)
+#'
+#'   ## Select three archetypes and from that the best
+#'   ## recurrence:
+#'   a3 <- bestModel(as[[3]])
+#'   }
+#'
+#' @export
+stepArchetypes <- function(..., k, nrep = 3, method = archetypes, verbose = TRUE) {
+
+  mycall <- match.call()
+  as <- 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])
+    }
+  }
+
+  return(structure(as, class='stepArchetypes', call=mycall))
+}
+
+
+#' @import methods
+setOldClass('repArchetypes')
+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(deparse(attr(x, 'call')), '\n')
+}
+
+
+
+#' Summary method for stepArchetypes object
+#'
+#' @param object A \code{stepArchetypes} object.
+#' @param ... Ignored.
+#' @return Undefined.
+#'
+#' @method summary stepArchetypes
+#' @rdname summary
+#'
+#' @S3method summary stepArchetypes
+summary.stepArchetypes <- function(object, ...) {
+  print(object)
+
+  ps <- nparameters(object)
+
+  for ( i in seq_along(object) ) {
+    cat('\nk=', ps[i], ':\n', sep='')
+    print(object[[i]], full=FALSE)
+  }
+}
+
+
+
+#' @rdname parameters
+#' @aliases parameters,stepArchetypes-method
+#' @importFrom modeltools parameters
+#' @import methods
+#' @exportMethod parameters
+setMethod('parameters', signature = c(object = 'stepArchetypes'),
+function(object, ...) {
+  lapply(object, parameters)
+})
+
+
+
+#' @rdname nparameters
+#' @method nparameters stepArchetypes
+#'
+#' @S3method nparameters stepArchetypes
+nparameters.stepArchetypes <- function(object, ...) {
+  return(sapply(object, nparameters))
+}
+
+
+
+#' @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)
+}
+
+
+
+#' 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)
+}
+
+
+
+#' @S3method print repArchetypes
+print.repArchetypes <- function(x, ...) {
+  for ( i in seq_along(x) )
+    print(x[[i]], ...)
+
+  invisible(x)
+}
+
+
+
+#' @rdname parameters
+#' @aliases parameters,repArchetypes-method
+#' @importFrom modeltools parameters
+#' @exportMethod parameters
+setMethod('parameters', signature = signature(object = 'repArchetypes'),
+function(object, ...) {
+  lapply(object, parameters)
+})
+
+ 
+
+#' @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)
+}
+
+
+
+#' @rdname nparameters
+#' @method nparameters repArchetypes
+#'
+#' @S3method nparameters repArchetypes
+nparameters.repArchetypes <- function(object, ...) {
+  nparameters(object[[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]])
+}
+
+

Modified: pkg/R/skeletonplot.R
===================================================================
--- pkg/R/skeletonplot.R	2014-04-09 13:27:05 UTC (rev 67)
+++ pkg/R/skeletonplot.R	2014-04-09 14:57:30 UTC (rev 68)
@@ -1,221 +1,224 @@
-
-
-#' Skeleton plot.
-#'
-#' Displays a schematic representation of skeleton data as available
-#' in dataset \code{\link{skel}}.
-#'
-#' @param x Matrix or data.frame of skeleton data.
-#' @param skel.width Reference width for instance calculation.
-#' @param skel.height Reference height for instance calculation.
-#' @param base.radius Base radius for points.
-#' @param xlab The x label of the plot.
-#' @param ylab The y label of the plot.
-#' @param xlim Numeric of length 2 giving the x limits for the plot.
-#' @param ylim Numeric of length 2 giving the y limits for the plot.
-#' @param col Color of the different parts of the skeleton.
-#' @param mtext Label archetypes.
-#' @param skel.lwd Line width of skeleton.
-#' @param ... Passed to underlying canvas plot function.
-#' @return List of skeleton instances.
-#' @export
-#' @seealso \code{\link{skel}}
-skeletonplot <- function(x, skel.width = 100, skel.height = 200,
-                         ylab = 'Height (cm)', base.radius = 2, xlab = '',
-                         xlim = (nrow(x)*c(0,skel.width)), ylim = c(0, skel.height),
-                         col = c(hipbase = 1, hip = 1, shoulderbase = 1, shoulder = 1,
-                                 head = 1, elbow = 2, wrist = 3, knee = 4, ankle = 5,
-                                 chest = 'purple1', pelvis = 6),
-                         mtext = TRUE, skel.lwd = 1, ...) {
-
-  if ( is.data.frame(x) )
-    x <- as.matrix(x)
-
-  ### Skeleton model (see human-modelling.vsd):
-  model.y <- c(ankle=0, knee=7, wrist=12, hip=13, hipbase=15, pelvis=16,
-               waist=17, elbow=20, chest=24, shoulder=26,
-               shoulderbase=27, head=30, top=32) / 32
-
-  model.x.leg <- c(hip=1, knee=1.5, ankle=1)
-  model.x.spine <- c(hipbase=0, pelvis=0, waist=0, chest=0, shoulderbase=0, head=0, top=0)
-  model.x.arm <- c(shoulder=1, elbow=5/3, wrist=5/3)
-
-
-  ### One skeleton instance:
-  one.skeleton <- function(x, x0=0) {
-
-    # Calculate instance:
-    skel.y <- model.y * x['Height']
-
-    skel.x.leg <- model.x.leg * (x['Bitro'] / 2)
-    skel.x.spine <- model.x.spine
-    skel.x.arm <- model.x.arm * (x['Biac'] / 2)
-    skel.x <- c(skel.x.leg, skel.x.spine, skel.x.arm)
-
-    skel.circles <- base.radius + c(hipbase=0, hip=0, shoulderbase=0,
-                                    shoulder=0, head=0,
-                                    elbow=unname(x['ElbowDiam'])/2,
-                                    wrist=unname(x['WristDiam'])/2,
-                                    knee=unname(x['KneeDiam'])/2,
-                                    ankle=unname(x['AnkleDiam'])/2) / 2
-
-    skel.rectangles <- rbind(chest=c(width=unname(x['ChestDiam']),
-                               height=unname(x['ChestDp'])),
-                             pelvis=c(width=unname(x['Biil']), height=0))
-
-
-    # Plot it:
-    lines(x0 + skel.x.spine, skel.y[names(skel.x.spine)],
-          lwd=skel.lwd, ...)
-
-    lines(x0 + c(skel.x.spine['hipbase'], skel.x.leg),
-          c(skel.y['hipbase'], skel.y[names(skel.x.leg)]),
-          lwd=skel.lwd, ...)
-    lines(x0 + c(skel.x.spine['hipbase'], -skel.x.leg),
-          c(skel.y['hipbase'], skel.y[names(skel.x.leg)]),
-          lwd=skel.lwd, ...)
-
-    lines(x0 + c(skel.x.spine['shoulderbase'], skel.x.arm),
-          c(skel.y['shoulderbase'], skel.y[names(skel.x.arm)]),
-          lwd=skel.lwd, ...)
-    lines(x0 + c(skel.x.spine['shoulderbase'], -skel.x.arm),
-          c(skel.y['shoulderbase'], skel.y[names(skel.x.arm)]),
-          lwd=skel.lwd, ...)
-
-    d <- names(skel.circles)
-    symbols(x0 + c(skel.x[d], -skel.x[d]), rep(skel.y[d], 2),
-            circles=rep(skel.circles[d], 2), fg=col[d], bg=col[d],
-            xlim=xlim, ylim=ylim, inches=FALSE, add=TRUE)
-
-    d <- rownames(skel.rectangles)
-    symbols(rep(x0, length(d)), skel.y[d],
-            rectangles=skel.rectangles, fg=col[d],
-            xlim=xlim, ylim=ylim, inches=FALSE, add=TRUE, lwd=2)
-
-    return(list(x0=x0, x=skel.x, y=skel.y,
-                circles=skel.circles, rectangles=skel.rectangles))
-  }
-
-
-  ### Plot:
-  nskels <- nrow(x)
-
-  yticks <- seq(ylim[1], ylim[2], by=20)
-  xticks <- seq(xlim[1], xlim[2], by=50)
-
-  # Canvas:
-  plot(1, xlim=xlim, ylim=ylim, type='n', xlab=xlab, ylab=ylab, axes=FALSE, ...)
-  axis(1, at=xticks)
-  axis(2, at=yticks)
-  box()
-
-  # Gridlines:
-  abline(v=xticks, col='lightgray', lty='dotted', lwd=1)
-  abline(h=yticks, col='lightgray', lty='dotted', lwd=1)
-
-  # Skeletons:
-  skels <- list()
-
-  for ( i in 1:nskels ) {
-    x0 <- (i-1) * skel.width + (skel.width/2)
-
-    skels[[i]] <- one.skeleton(x[i,], x0=x0)
-
-    if ( mtext )
-      mtext(paste('Archetype', i), side=3, line=0, at=x0)
-  }
-
-
-  invisible(skels)
-}
-
-
-
-#' Annotated skeleton plot.
-#'
-#' Displays a generic skeleton with annotations explaining the
-#' measurements available in data set \code{\link{skel}}.
-#'
-#' @return Generic skeleton instance.
-#' @rdname skeletonplot
-#'
-#' @export
-jd <- function() {
-  jd <- rbind(c(AnkleDiam=13.9, KneeDiam=18.8, WristDiam=10.5, Bitro=32.0,
-                Biil=27.8, ElbowDiam=13.4, ChestDiam=28.0, ChestDp=15,
-                Biac=38.8, Height=171.1))
-
-  s <- skeletonplot(jd, skel.height=190,
-                    mtext=FALSE, xlim=c(-100,200), skel.lwd=1)[[1]]
-
-
-  ### Annotate JD:
-  acol <- gray(0.5)
-
-  annotation1 <- function(text, x, y, alen=10) {
-    ws <- 0
-
-    arrows(x, y, x+alen, y,
-           length=0.1, code=1, col=acol, lwd=1)
-
-    text(labels=text,
-         x=x+alen+ws, y=y, pos=ifelse(alen<0,2,4), col=acol)
-  }
-
-  annotation2 <- function(text, xb, xd, y, offset, alen=-30) {
-    x0 <- xb - xd
-    x1 <- xb + xd
-
-    lines(c(x0, x0), c(y, y+offset), col=acol)
-    lines(c(x1, x1), c(y, y+offset), col=acol)
-
-    arrows(x0, y+offset, x1, y+offset,
-           code=3, length=0.1, col=acol)
-
-    lines(c(x0, x0+alen), c(y+offset, y+offset), col=acol)
-
-    text(labels=text, x=x0+alen, y=y+offset, pos=2, col=acol)
-  }
-
-
-  annotation1('Diameter of ankle',
-              s$x0 + s$x['ankle'] + s$circles['ankle'],
-              s$y['ankle'])
-
-  annotation1('Diameter of knee',
-              s$x0 + s$x['knee'] + s$circles['knee'],
-              s$y['knee'])
-
-  annotation1('Diameter of wrist',
-              s$x0 + s$x['wrist'] + s$circles['wrist'],
-              s$y['wrist'])
-
-  annotation1('Diameter of pelvis\n(biiliac)',
-              s$x0 + s$x['pelvis'] + s$rectangles['pelvis','width']/2,
-              s$y['pelvis'], alen=25)
-
-  annotation1('Diameter of elbow',
-              s$x0 + s$x['elbow'] + s$circles['elbow'],
-              s$y['elbow'])
-
-  annotation1('Height',
-              s$x0 + s$x['top'],
-              s$y['top'])
-
-  annotation2('Diameter between\nhips (bitrochanteric)',
-              s$x0, s$x['hip'], s$y['hip'] - s$circles['hip'], -15)
-
-  annotation2('Diameter between\nshoulders (biacromial)',
-              s$x0, s$x['shoulder'], s$y['shoulder'] + s$circles['shoulder'], 10)
-
-  annotation2('Diameter of chest',
-              s$x0, s$rectangles['chest','width']/2,
-              s$y['chest'] - s$rectangles['chest','height']/2, -5)
-
-  annotation1('Depth of chest',
[TRUNCATED]

To get the complete diff run:
    svnlook diff /svnroot/archetypes -r 68

From noreply at r-forge.r-project.org  Thu Apr 10 08:00:40 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu, 10 Apr 2014 08:00:40 +0200 (CEST)
Subject: [Archetypes-commits] r69 - pkg
Message-ID: <20140410060040.7C1AD184C61@r-forge.r-project.org>

Author: manuel
Date: 2014-04-10 08:00:39 +0200 (Thu, 10 Apr 2014)
New Revision: 69

Modified:
   pkg/DESCRIPTION
Log:
typos

Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION	2014-04-09 14:57:30 UTC (rev 68)
+++ pkg/DESCRIPTION	2014-04-10 06:00:39 UTC (rev 69)
@@ -18,8 +18,8 @@
     "manuel at mjae.net"), person("Friedrich", "Leisch", role = "aut"),
     person("Sohan", "Seth", role = "ctb"))
 Description: The main function archetypes implements a
-    framework for archetypal analysis supporting arbitary
-    problem solving mechanisms for the different conceputal
+    framework for archetypal analysis supporting arbitrary
+    problem solving mechanisms for the different conceptual
     parts of the algorithm.
 License: GPL (>= 2)
 Collate:


From noreply at r-forge.r-project.org  Thu Apr 10 08:10:58 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu, 10 Apr 2014 08:10:58 +0200 (CEST)
Subject: [Archetypes-commits] r70 - pkg
Message-ID: <20140410061058.8CAF418459B@r-forge.r-project.org>

Author: manuel
Date: 2014-04-10 08:10:50 +0200 (Thu, 10 Apr 2014)
New Revision: 70

Added:
   pkg/00Notes
Log:
How to build pkg for CRAN

Added: pkg/00Notes
===================================================================
--- pkg/00Notes	                        (rev 0)
+++ pkg/00Notes	2014-04-10 06:10:50 UTC (rev 70)
@@ -0,0 +1,4 @@
+
+- Remember to build the packge for CRAN as follows:
+  R CMD BUILD --compact-vignettes=gs+qpdf pkg
+  R CMD CHECK --as-cran archetypes_2.2-0.tar.gz