[Vegan-commits] r1148 - pkg/permute/R

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

Author: gsimpson
Date: 2010-02-28 14:21:34 +0100 (Sun, 28 Feb 2010)
New Revision: 1148

Added:
   pkg/permute/R/allFree.R
   pkg/permute/R/allGrid.R
   pkg/permute/R/allSeries.R
   pkg/permute/R/allStrata.R
Log:
Move inline utility functions out of allPerms and rename

Added: pkg/permute/R/allFree.R
===================================================================
--- pkg/permute/R/allFree.R	                        (rev 0)
+++ pkg/permute/R/allFree.R	2010-02-28 13:21:34 UTC (rev 1148)
@@ -0,0 +1,11 @@
+`allFree` <- function(n, v = 1:n)
+{
+    if( n == 1 ) {
+        matrix(v, 1, 1)
+    } else {
+        X <- NULL
+        for(i in 1:n)
+            X <- rbind(X, cbind(v[i], Recall(n-1, v[-i])))
+        X
+    }
+}

Added: pkg/permute/R/allGrid.R
===================================================================
--- pkg/permute/R/allGrid.R	                        (rev 0)
+++ pkg/permute/R/allGrid.R	2010-02-28 13:21:34 UTC (rev 1148)
@@ -0,0 +1,40 @@
+`allGrid` <- function(n, nperms, nr, nc, mirror, constant)
+{
+    v <- seq_len(n)
+    X <- matrix(nrow = nperms, ncol = n)
+    idx <- 1
+    ## ncol == 2 is special case
+    if(nc == 2) {
+        X <- allSeries(n,
+                       permControl(within =
+                                   Within(type = "series",
+                                          mirror = mirror,
+                                          constant = constant)))
+    } else {
+        for(i in seq_len(nr)) {
+            for(j in seq_len(nc)) {
+                ir <- seq(i, length = nr)%%nr
+                ic <- seq(j, length = nc)%%nc
+                ## block 1 - no reversals
+                X[idx, ] <- rep(ic, each = nr) * nr +
+                    rep(ir, len = nr * nc) + 1
+                if(mirror) {
+                    ## block 2 - rev rows but not columns
+                    X[idx + n, ] <- rep(ic, each = nr) * nr +
+                        rep(rev(ir), len = nr * nc) + 1
+                    ## block 3 - rev columns but not rows
+                    X[idx + (2*n), ] <- rep(rev(ic), each = nr) *
+                        nr + rep(ir, len = nr * nc) + 1
+                }
+                idx <- idx + 1
+            }
+        }
+        if(mirror) {
+            ## rev columns and rows
+            ## no calculations, just rev cols of block 1
+            v <- seq_len(n)
+            X[((3*n)+1):(4*n), ] <- X[v, rev(v)]
+        }
+    }
+    X
+}

Added: pkg/permute/R/allSeries.R
===================================================================
--- pkg/permute/R/allSeries.R	                        (rev 0)
+++ pkg/permute/R/allSeries.R	2010-02-28 13:21:34 UTC (rev 1148)
@@ -0,0 +1,13 @@
+`allSeries` <- function(n, nperms, mirror = FALSE)
+{
+    v <- seq_len(n)
+    X <- matrix(nrow = nperms, ncol = n)
+    for(i in v) {
+        X[i,] <- seq(i, length = n)%%n + 1
+    }
+    ## if mirroring, rev the cols of X[v,]
+    ## but only if nperms > 2
+    if(mirror && (nperms > 2))
+        X[(n+1):(2*n),] <- X[v, rev(v)]
+    X
+}

Added: pkg/permute/R/allStrata.R
===================================================================
--- pkg/permute/R/allStrata.R	                        (rev 0)
+++ pkg/permute/R/allStrata.R	2010-02-28 13:21:34 UTC (rev 1148)
@@ -0,0 +1,37 @@
+`allStrata` <- function(n, control)
+{
+    ## seq vector of observation indices
+    v <- seq_len(n)
+    ## number of groups
+    lev <- length(levels(control$strata))
+    ## compute nperms on number of levels
+    nperms <- numPerms(lev, control)
+    ## result object
+    X <- matrix(nrow = nperms, ncol = length(control$strata))
+    ## store the type
+    type <- control$blocks$type
+    perms <- if(type == "free") {
+        allFree(lev)
+    } else if(type == "series") {
+        mirror <- control$blocks$mirror
+        allSeries(lev, nperms = nperms, mirror = mirror)
+    } else if(type == "grid") {
+        nr <- control$blocks$nrow
+        nc <- control$blocks$ncol
+        mirror <- control$blocks$mirror
+        constant <- control$blocks$constant
+        allGrid(lev, nperms = nperms, nr = nr, nc = nc,
+                mirror = mirror, constant = constant)
+    } else {
+        ## if in here, must have both types == "none"
+        ## this is here just in case - need to check if this
+        ## is possible given calling function...
+        return(v)
+    }
+    sp <- split(v, control$strata)
+    ## build permutations by concatenating components of sp
+    ## for each row of level permutations
+    for(i in seq_len(nrow(perms)))
+        X[i,] <- unname(do.call(c, sp[perms[i,]]))
+    return(X)
+}