[Archetypes-commits] r27 - in branches/pkg-robust: R sandbox

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

Author: manuel
Date: 2010-02-25 15:27:36 +0100 (Thu, 25 Feb 2010)
New Revision: 27

Modified:
   branches/pkg-robust/R/archetypes-class.R
   branches/pkg-robust/R/archetypes-diagplots.R
   branches/pkg-robust/R/archetypes-kit-blocks.R
   branches/pkg-robust/R/archetypes-kit.R
   branches/pkg-robust/sandbox/demo.R
Log:
holiday submission!!!

Modified: branches/pkg-robust/R/archetypes-class.R
===================================================================
--- branches/pkg-robust/R/archetypes-class.R	2010-02-23 16:30:42 UTC (rev 26)
+++ branches/pkg-robust/R/archetypes-class.R	2010-02-25 14:27:36 UTC (rev 27)
@@ -46,6 +46,8 @@
 }
 
 setOldClass('archetypes')
+setOldClass('weightedArchetypes')
+setOldClass('robustArchetypes')
 
 
 
@@ -92,6 +94,8 @@
 
 #' @importFrom modeltools parameters
 setMethod('parameters', 'archetypes', parameters.archetypes)
+setMethod('parameters', 'weightedArchetypes', parameters.archetypes)
+setMethod('parameters', 'robustArchetypes', parameters.archetypes)
 
 
 

Modified: branches/pkg-robust/R/archetypes-diagplots.R
===================================================================
--- branches/pkg-robust/R/archetypes-diagplots.R	2010-02-23 16:30:42 UTC (rev 26)
+++ branches/pkg-robust/R/archetypes-diagplots.R	2010-02-25 14:27:36 UTC (rev 27)
@@ -1,5 +1,5 @@
+### distanz von jedem archetyp zum nächsten punkt
 
-
 residuals.diagplot <- function(object, ref.order = 1, ...) {
   y <- residuals(object)
   x <- seq(length = nrow(y))
@@ -26,7 +26,8 @@
     abline(h = 0, lty = 2, col = gray(0.7), ...)
   }
 
-  invisible(NULL)
+
+  invisible(list(x = x, y = y))
 }
 
 
@@ -40,10 +41,13 @@
   x <- seq(length = length(y))
 
   if ( sort )
-    y <- sort(y)
+    xy <- sort(y)
 
   plot(x, y, xlab = 'Index', ylab = 'RSS', ...)
   abline(h = 0, lty = 2, col = gray(0.7), ...)
+
+
+  invisible(list(x = x, y = y))
 }
 
 rss.diagplot.repArchetypes <- function(object, ...) {
@@ -128,3 +132,25 @@
   plot(x, y1, type = 'l', xlab = 'Iterations', ylab = 'Reweights', ...)
   plot(x, y2, type = 'l', xlab = 'Iterations', ylab = 'RSS', ...)
 }
+
+
+archetypes.view.diagplot <- function(object, data, ref.order = NULL,
+                                     distfn = distEuclidean, ...) {
+
+  d <- distfn(data, parameters(object))
+  x <- seq(length = nrow(d))
+
+  if ( is.null(ref.order) )
+    ix <- x
+  else
+    ix <- order(d[, 1])
+
+  ylim <- c(0, max(d))
+
+  par(mfrow = c(ncol(d), 1))
+  for ( i in seq(length = ncol(d)) )
+    plot(x, d[ix, i], xlab = sprintf('Archetype %s', i), ylab = 'Distance',
+         ylim = ylim, ...)
+
+  invisible(d)
+}

Modified: branches/pkg-robust/R/archetypes-kit-blocks.R
===================================================================
--- branches/pkg-robust/R/archetypes-kit-blocks.R	2010-02-23 16:30:42 UTC (rev 26)
+++ branches/pkg-robust/R/archetypes-kit-blocks.R	2010-02-25 14:27:36 UTC (rev 27)
@@ -297,7 +297,7 @@
 
 ### Reweighting functions:
 
-bisquare0.reweightsfn <- function(resid) {
+bisquare0.reweightsfn <- function(resid, reweights) {
   resid <- apply(resid, 2, function(x) sum(abs(x)))
   resid0 <- resid < sqrt(.Machine$double.eps)
 
@@ -306,7 +306,7 @@
   ifelse(s < 1, (1 - s^2)^2, 0)
 }
 
-bisquare.reweightsfn <- function(resid) {
+bisquare.reweightsfn <- function(resid, reweights) {
   resid.abs <- apply(resid, 2, function(x) sum(abs(x)))
 
   mar <- mad(resid.abs, constant = 1) / 0.6754
@@ -317,7 +317,7 @@
   ifelse(resid.abs <= k, (1 - resid.euc)^2, 0)
 }
 
-tricube.reweightsfn <- function(resid) {
+tricube.reweightsfn <- function(resid, reweights) {
   resid <- apply(resid, 2, function(x) sum(abs(x)))
   ifelse(resid < 1, (1 - resid^3)^3, 0)
 }

Modified: branches/pkg-robust/R/archetypes-kit.R
===================================================================
--- branches/pkg-robust/R/archetypes-kit.R	2010-02-23 16:30:42 UTC (rev 26)
+++ branches/pkg-robust/R/archetypes-kit.R	2010-02-25 14:27:36 UTC (rev 27)
@@ -94,7 +94,7 @@
   tryCatch(while ( (i <= maxIterations) & (imp >= minImprovement) ) {
 
     ## Reweight data:
-    reweights <- family$reweightsfn(resid)
+    reweights <- family$reweightsfn(resid, reweights)
     x <- family$weightfn(x0, reweights)
 
 

Modified: branches/pkg-robust/sandbox/demo.R
===================================================================
--- branches/pkg-robust/sandbox/demo.R	2010-02-23 16:30:42 UTC (rev 26)
+++ branches/pkg-robust/sandbox/demo.R	2010-02-25 14:27:36 UTC (rev 27)
@@ -79,10 +79,14 @@
 plot(a1, toy.o1, adata.show = TRUE)
 
 residuals.diagplot(a1)
+
 rss.diagplot(a1)
+rss.diagplot(a1, sort = TRUE)
 
+archetypes.view.diagplot(a1, toy.o1)
 
 
+
 ### Weighted archetypes:
 
 w <- rep(c(1, 0), c(250, 5))
@@ -106,6 +110,9 @@
 rss.diagplot(ra1)
 weights.diagplot(ra1, weights.type = 'reweights')
 
+archetypes.view.diagplot(ra1, toy.o1)
+archetypes.view.diagplot(ra1, toy.o1, ref.order = 1)
+
 par(mfrow = c(6, 7), mar = c(0, 0, 0, 0))
 movieplot(ra1, toy.o1, adata.show = TRUE, link.col.show = FALSE,
           link.lty = 0, axes = FALSE, postfn = function(iter) box())
@@ -168,17 +175,8 @@
 
 ### So, as always, it is not the easy solution ... ###################
 
-set.seed(1235)
-ra2 <- archetypes(toy.o1, 3, family = archetypesFamily('robust',
-                             reweightsfn = bisquare.reweightsfn))
-
-plot(ra2, toy.o1, adata.show = TRUE)
-
-weights.diagplot(ra2, weights.type = 'reweights')
-rss.diagplot(ra2)
-
-par(mfrow = c(2, 5), mar = c(0, 0, 0, 0))
-movieplot(ra2, toy.o1, adata.show = TRUE, link.col.show = FALSE,
-          link.lty = 0, axes = FALSE, postfn = function(iter) box())
-
-reweights.rss.diagplot(ra2)
+# * Burn-In phase
+# * Initial archtypes drawn around the data's median
+# * "Refrigerative" reweights (similar to simulated annealing)
+# * Multi-dimensional median?
+# * Weights for alpha and beta separately