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

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

Author: gsimpson
Date: 2013-11-21 17:24:14 +0100 (Thu, 21 Nov 2013)
New Revision: 2719

Modified:
   pkg/permute/R/getFoo-methods.R
Log:
add some new meothods to work with Plots and Within classed objects

Modified: pkg/permute/R/getFoo-methods.R
===================================================================
--- pkg/permute/R/getFoo-methods.R	2013-11-21 16:06:35 UTC (rev 2718)
+++ pkg/permute/R/getFoo-methods.R	2013-11-21 16:24:14 UTC (rev 2719)
@@ -1,66 +1,66 @@
 ## Extractor functions for blocks, plots and within, plus strata
 
 ## Blocks
-getBlocks <- function(object, ...) {
+`getBlocks` <- function(object, ...) {
     UseMethod("getBlocks")
 }
 
-getBlocks.default <- function(object, ...) {
+`getBlocks.default` <- function(object, ...) {
     stop("No default method for 'getBlocks()'")
 }
 
-getBlocks.permControl <- function(object, ...) {
+`getBlocks.permControl` <- function(object, ...) {
     object$blocks
 }
 
-getBlocks.how <- function(object, ...) {
+`getBlocks.how` <- function(object, ...) {
     object$blocks
 }
 
 ## Plots
-getPlots <- function(object, ...) {
+`getPlots` <- function(object, ...) {
     UseMethod("getPlots")
 }
 
-getPlots.default <- function(object, ...) {
+`getPlots.default` <- function(object, ...) {
     stop("No default method for 'getPlots()'")
 }
 
-getPlots.permControl <- function(object, ...) {
+`getPlots.permControl` <- function(object, ...) {
     object$plots
 }
 
-getPlots.how <- function(object, ...) {
+`getPlots.how` <- function(object, ...) {
     object$plots
 }
 
 ## Within plots
-getWithin <- function(object, ...) {
+`getWithin` <- function(object, ...) {
     UseMethod("getWithin")
 }
 
-getWithin.default <- function(object, ...) {
+`getWithin.default` <- function(object, ...) {
     stop("No default method for 'getWithin()'")
 }
 
-getWithin.permControl <- function(object, ...) {
+`getWithin.permControl` <- function(object, ...) {
     object$within
 }
 
-getWithin.how <- function(object, ...) {
+`getWithin.how` <- function(object, ...) {
     object$within
 }
 
 ## Strata
-getStrata <- function(object, ...) {
+`getStrata` <- function(object, ...) {
     UseMethod("getStrata")
 }
 
-getStrata.default <- function(object, ...) {
+`getStrata.default` <- function(object, ...) {
     stop("No default method for 'getStrata()'")
 }
 
-getStrata.permControl <- function(object,
+`getStrata.permControl` <- function(object,
                                   which = c("plots", "blocks"),
                                   drop = TRUE, ...) {
     which <- match.arg(which)
@@ -74,7 +74,7 @@
     strata
 }
 
-getStrata.how <- function(object,
+`getStrata.how` <- function(object,
                                   which = c("plots","blocks"),
                                   drop = TRUE, ...) {
     which <- match.arg(which)
@@ -89,17 +89,24 @@
     strata
 }
 
+`getStrata.Plots` <- function(object, drop = TRUE, ... ) {
+    strata <- object$strata
+    if(isTRUE(drop) && !is.null(strata))
+        strata <- droplevels(strata)
+    strata
+}
+
 ## Get type of permutation
-getType <- function(object, ...) {
+`getType` <- function(object, ...) {
     UseMethod("getType")
 }
 
-getType.default <- function(object, ...) {
+`getType.default` <- function(object, ...) {
     stop("No default method for 'getType()'")
 }
 
-getType.permControl <- function(object,
-                                which = c("plots","within"), ...) {
+`getType.permControl` <- function(object,
+                                  which = c("plots","within"), ...) {
     which <- match.arg(which)
   if(isTRUE(all.equal(which, "plots")))
       type <- getPlots(object)$type
@@ -110,8 +117,8 @@
   type
 }
 
-getType.how <- function(object,
-                                which = c("plots","within"), ...) {
+`getType.how` <- function(object,
+                          which = c("plots","within"), ...) {
     which <- match.arg(which)
   if(isTRUE(all.equal(which, "plots")))
       type <- getPlots(object)$type
@@ -122,6 +129,14 @@
   type
 }
 
+`getType.Within` <- function(object, ...) {
+    object$within$type
+}
+
+`getType.Plots` <- function(object, ...) {
+    object$plots$type
+}
+
 ## suppose we can also have setBlocks() etc...
 ## to update the control object in place....
 
@@ -158,6 +173,14 @@
     mirror
 }
 
+`getMirror.Within` <- function(object, ...) {
+    object$within$mirror
+}
+
+`getMirror.Plots` <- function(object, ...) {
+    object$plots$mirror
+}
+
 ## Get constant status - i.e. same permutation in each Plot
 `getConstant` <- function(object, ...) {
     UseMethod("getConstant")
@@ -175,6 +198,10 @@
     getWithin(object)$constant
 }
 
+`getConstant.Within` <- function(object, ...) {
+    object$within$constant
+}
+
 ## Get the number of rows and colums from grid designs
 `getRow` <- function(object, ...) {
     UseMethod("getRow")
@@ -208,6 +235,14 @@
     nrow
 }
 
+`getRow.Within` <- function(object, ...) {
+    object$within$nrow
+}
+
+`getRow.Plots` <- function(object, ...) {
+    object$plots$nrow
+}
+
 `getCol` <- function(object, ...) {
     UseMethod("getCol")
 }
@@ -240,6 +275,14 @@
     ncol
 }
 
+`getCol.Within` <- function(object, ...) {
+    object$within$ncol
+}
+
+`getCol.Plots` <- function(object, ...) {
+    object$plots$ncol
+}
+
 `getDim` <- function(object, ...) {
     UseMethod("getDim")
 }
@@ -282,6 +325,14 @@
     c(nr, nc)
 }
 
+`getDim.Within` <- function(object, ...) {
+    c(object$nrow, object$ncol)
+}
+
+`getDim.Plots` <- function(object, ...) {
+    c(object$nrow, object$ncol)
+}
+
 ## return the requested number of permutations
 `getNperm` <- function(object, ...) {
     UseMethod("getNperm")