[Archetypes-commits] r39 - in branches/pkg-robust: . R

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

Author: manuel
Date: 2010-04-06 11:17:41 +0200 (Tue, 06 Apr 2010)
New Revision: 39

Modified:
   branches/pkg-robust/NEWS
   branches/pkg-robust/R/archetypes-class.R
   branches/pkg-robust/R/archetypes-kit-blocks.R
   branches/pkg-robust/R/archetypes-kit.R
   branches/pkg-robust/R/archetypes-robust.R
   branches/pkg-robust/R/archetypes-weighted.R
Log:


Modified: branches/pkg-robust/NEWS
===================================================================
--- branches/pkg-robust/NEWS	2010-04-01 14:28:23 UTC (rev 38)
+++ branches/pkg-robust/NEWS	2010-04-06 09:17:41 UTC (rev 39)
@@ -1,7 +1,8 @@
 
 Changes in archetypes version 2.0
 
-  o cleaned up interface; see '?archetypes-deprecated'.
+  o cleaned up interface; see '?archetypes-deprecated' and
+    '?archetypes-generics'.
 
   o added weighted and robust archetypes; see 'demo(robust-toy)' and
     'demo(robust-ozone)'.

Modified: branches/pkg-robust/R/archetypes-class.R
===================================================================
--- branches/pkg-robust/R/archetypes-class.R	2010-04-01 14:28:23 UTC (rev 38)
+++ branches/pkg-robust/R/archetypes-class.R	2010-04-06 09:17:41 UTC (rev 39)
@@ -23,6 +23,7 @@
 #'   \code{archetypes}.
 #' @seealso \code{\link{archetypes}}
 #' @rdname archetypes-class
+#' @aliases archetypes-class
 as.archetypes <- function(archetypes, k, alphas, rss, iters = NULL, call = NULL,
                           history = NULL, kappas = NULL, betas = NULL, zas = NULL,
                           family = NULL, familyArgs = NULL, residuals = NULL,

Modified: branches/pkg-robust/R/archetypes-kit-blocks.R
===================================================================
--- branches/pkg-robust/R/archetypes-kit-blocks.R	2010-04-01 14:28:23 UTC (rev 38)
+++ branches/pkg-robust/R/archetypes-kit-blocks.R	2010-04-06 09:17:41 UTC (rev 39)
@@ -259,15 +259,15 @@
 
   bp.initfn <- function(x, p, ...) {
 
-    n = ncol(x)
-    b = matrix(0, nrow=n, ncol=p)
+    n <- ncol(x)
+    b <- matrix(0, nrow=n, ncol=p)
 
     for ( i in 1:p )
-      b[sample(n, k, replace=FALSE),i] = 1 / k
+      b[sample(n, k, replace=FALSE),i] <- 1 / k
 
-    a = matrix(1, nrow=p, ncol=n) / p
+    a <- matrix(1, nrow = p, ncol = n) / p
 
-    return(list(betas=b, alphas=a))
+    return(list(betas = b, alphas = a))
   }
 
   return(bp.initfn)
@@ -280,12 +280,12 @@
 make.fix.initfn <- function(indizes) {
 
   fix.initfn <- function(x, p, ...) {
-    n = ncol(x)
+    n <- ncol(x)
 
-    b = matrix(0, nrow = n, ncol = p)
-    b[indizes,] = diag(p)
+    b <- matrix(0, nrow = n, ncol = p)
+    b[indizes, ] <- diag(p)
 
-    a = matrix(1, nrow = p, ncol = n) / p
+    a <- matrix(1, nrow = p, ncol = n) / p
 
     return(list(betas = b, alphas = a))
   }
@@ -323,8 +323,32 @@
   data
 }
 
+#' Global weight function: move data closer to global center
+#' @param data A numeric \eqn{m \times n} data matrix.
+#' @param weights Vector or matrix of data weights within \eqn{[0, 1]}.
+#' @return Weighted data matrix.
+#' @nord
+center.globweightfn <- function(data, weights, ...) {
+  if ( is.null(weights) )
+    return(data)
 
+  if ( is.vector(weights) )
+    weights <- diag(weights)
 
+  dr <- attr(data, '.Meta')$dummyrow
+
+  if ( is.null(dr) ) {
+    data <- data %*% weights
+  }
+  else {
+    data[-dr, ] <- data[-dr, ] %*% weights
+  }
+
+  data
+}
+
+
+
 ### Reweights functions: #############################################
 
 
@@ -409,6 +433,7 @@
        alphasfn = nnls.alphasfn,
        betasfn = nnls.betasfn,
        zalphasfn = qrsolve.zalphasfn,
+       globweightfn = function(x, weights) x,
        weightfn = function(x, weights) x,
        reweightsfn = function(x, weights) weights,
        class = NULL)

Modified: branches/pkg-robust/R/archetypes-kit.R
===================================================================
--- branches/pkg-robust/R/archetypes-kit.R	2010-04-01 14:28:23 UTC (rev 38)
+++ branches/pkg-robust/R/archetypes-kit.R	2010-04-06 09:17:41 UTC (rev 39)
@@ -7,7 +7,8 @@
 #' Perform archetypal analysis on a data matrix.
 #' @param data A numeric \eqn{n \times m} data matrix.
 #' @param k The number of archetypes.
-#' @param weights Data weights matrix.
+#' @param weights Data weights matrix or vector (used as elements of
+#'   the diagonal weights matrix).
 #' @param maxIterations The maximum number of iterations.
 #' @param minImprovement The minimal value of improvement between two
 #'   iterations.
@@ -18,9 +19,9 @@
 #' @param family Blocks defining the underlying problem solving mechanisms;
 #'   see \code{\link{archetypesFamily}}.
 #' @param ... Additional arguments for family blocks.
-#' @return An object of class \code{\link{archetypes}}, see
-#'   \code{\link{as.archetypes}}.
-#' @seealso \code{\link{stepArchetypes}}
+#' @return An object of class \code{archetypes}, see
+#'   \code{\link{archetypes-class}}.
+#' @seealso \code{\link{stepArchetypes}}, \code{\link{archetypes-class}}
 #' @references Cutler and Breiman. Archetypal Analysis. Technometrics,
 #'   36(4), 1994. 338-348.
 #' @examples
@@ -59,7 +60,7 @@
   x1 <- t(data)
   x1 <- family$scalefn(x1, ...)
   x1 <- family$dummyfn(x1, ...)
-  x0 <- family$weightfn(x1, weights, ...)
+  x0 <- family$globweightfn(x1, weights, ...)
   x <- x0
 
   n <- ncol(x)

Modified: branches/pkg-robust/R/archetypes-robust.R
===================================================================
--- branches/pkg-robust/R/archetypes-robust.R	2010-04-01 14:28:23 UTC (rev 38)
+++ branches/pkg-robust/R/archetypes-robust.R	2010-04-06 09:17:41 UTC (rev 39)
@@ -8,8 +8,8 @@
 #' @param k The number of archetypes.
 #' @param familyBlocks Exchange predefined family blocks.
 #' @param ... Arguments available for \code{\link{archetypes}}.
-#' @return An object of class \code{robustArchetypes}and
-#'   \code{\link{archetypes}}.
+#' @return An object of class \code{robustArchetypes} and
+#'   \code{\link{archetypes-class}}.
 #' @export
 #' @rdname archetypes
 robustArchetypes <- function(data, k, familyBlocks = list(), ...) {

Modified: branches/pkg-robust/R/archetypes-weighted.R
===================================================================
--- branches/pkg-robust/R/archetypes-weighted.R	2010-04-01 14:28:23 UTC (rev 38)
+++ branches/pkg-robust/R/archetypes-weighted.R	2010-04-06 09:17:41 UTC (rev 39)
@@ -9,8 +9,8 @@
 #' @param weights Data weights matrix.
 #' @param familyBlocks Exchange predefined family blocks.
 #' @param ... Arguments available for \code{\link{archetypes}}.
-#' @return An object of class \code{weightedArchetypes}and
-#'   \code{\link{archetypes}}.
+#' @return An object of class \code{weightedArchetypes} and
+#'   \code{\link{archetypes-class}}.
 #' @export
 #' @rdname archetypes
 weightedArchetypes <- function(data, k, weights = NULL,
@@ -29,7 +29,7 @@
 .weighted.archetypesFamily <- function() {
   f <- .original.archetypesFamily()
   f$class <- 'weightedArchetypes'
-  f$weightfn <- center.weightfn
+  f$globweightfn <- center.globweightfn
   f
 }