[Archetypes-commits] r12 - in pkg: . R

[noreply at r-forge.r-project.org]

Author: manuel
Date: 2009-01-06 16:46:06 +0100 (Tue, 06 Jan 2009)
New Revision: 12

Modified:
   pkg/DESCRIPTION
   pkg/R/archetypes-class.R
   pkg/R/archetypes-kit.R
   pkg/R/archetypes-movie.R
Log:
Extend as.archetypes() to create a more detailed movieplot

Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION	2008-12-10 16:20:48 UTC (rev 11)
+++ pkg/DESCRIPTION	2009-01-06 15:46:06 UTC (rev 12)
@@ -10,7 +10,6 @@
 Description: The main function archetypes implements a framework for
   archetypal analysis supporting arbitary problem solving mechanisms
   for the different conceputal parts of the algorithm.
-
   NOTE: This package is used as real-world test application for the
   Roxygen documentation system. At the moment, Roxygen does not produce
   "good" help pages for the everyday use of a package; we refer to the

Modified: pkg/R/archetypes-class.R
===================================================================
--- pkg/R/archetypes-class.R	2008-12-10 16:20:48 UTC (rev 11)
+++ pkg/R/archetypes-class.R	2009-01-06 15:46:06 UTC (rev 12)
@@ -12,6 +12,8 @@
 #' @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 $p \times n$ matrix.
+#' @param zas The temporary archetypes.
 #' @return A list with an element for each parameter and class attribute
 #'   \code{archetypes}.
 #' @seealso \code{\link{archetypes}}, \code{\link{atypes}}, \code{\link{ntypes}},
@@ -19,7 +21,7 @@
 #'   \code{\link{ahistory}}, \code{\link{nhistory}}
 #' @export
 as.archetypes <- function(archetypes, k, alphas, rss, iters=NULL, call=NULL,
-                          history=NULL, kappas=NULL) {
+                          history=NULL, kappas=NULL, betas=NULL, zas=NULL) {
   
   return(structure(list(archetypes=archetypes,
                         k=k,
@@ -27,6 +29,8 @@
                         rss=rss,
                         iters=iters,
                         kappas=kappas,
+                        betas=betas,
+                        zas=zas,
                         call=call,
                         history=history),
                    class='archetypes'))  

Modified: pkg/R/archetypes-kit.R
===================================================================
--- pkg/R/archetypes-kit.R	2008-12-10 16:20:48 UTC (rev 11)
+++ pkg/R/archetypes-kit.R	2009-01-06 15:46:06 UTC (rev 12)
@@ -39,7 +39,9 @@
     history[[paste('s', name, sep='')]] <-
       list(archetypes=as.archetypes(t(family$rescalefn(x,
              family$undummyfn(x, zs))), k, alphas=t(alphas),
-             rss=rss, kappas=kappas))
+             betas=t(betas), zas=t(family$rescalefn(x,
+             family$undummyfn(x, zas))), rss=rss,
+             kappas=kappas))
   }
 
 
@@ -61,6 +63,8 @@
   zs <- x %*% betas
   rss <- family$normfn(zs %*% alphas - x) / n
 
+  zas <- NULL
+
   kappas <- c(alphas=kappa(alphas), betas=kappa(betas),
               zas=-Inf, zs=kappa(zs))
   isIll <- c(kappas) > maxKappa
@@ -137,5 +141,6 @@
 
   
   return(as.archetypes(zs, k, t(alphas), rss, iters=(i-1),
-                       call=mycall, history=history, kappas=kappas))
+                       call=mycall, history=history, kappas=kappas,
+                       betas=t(betas)))
 }

Modified: pkg/R/archetypes-movie.R
===================================================================
--- pkg/R/archetypes-movie.R	2008-12-10 16:20:48 UTC (rev 11)
+++ pkg/R/archetypes-movie.R	2009-01-06 15:46:06 UTC (rev 12)
@@ -30,7 +30,55 @@
 }
 
 
+#' Archetypes plot movie 2.
+#'
+#' 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
+movieplot2 <- function(zs, data, show='atypes',
+                       ssleep=0, bsleep=0,
+                       zas.col=2, zas.pch=13,
+                       old.col=rgb(1,0.5,0.5), ...) {
 
+  steps <- length(zs$history)
+
+  Sys.sleep(ssleep)
+
+  # Initial archetypes:
+  a <- ahistory(zs, step=0)
+  plot(a, data, ...)
+  Sys.sleep(bsleep)
+
+  # Alternating loop:
+  for ( i in seq_len(steps-1) ) {
+    a0 <- ahistory(zs, step=(i-1))
+    a <- ahistory(zs, step=i)
+
+    plot(a0, data, atypes.col=old.col, ...)
+    points(a$zas, col=zas.col, pch=zas.pch, ...)
+    Sys.sleep(bsleep)
+
+    plot(a0, data, atypes.col=old.col, ...)
+    points(a$zas, col=zas.col, pch=zas.pch, ...)
+    par(new=TRUE)
+    plot(a, data, ...)
+    Sys.sleep(bsleep)
+  }
+  
+  plot(a, data, ...)
+}
+
+
 #' Archetypes parallel coordinates plot movie.
 #' @param zs An \code{\link{archetypes}} object.
 #' @param data The data matrix.