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

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

Author: gsimpson
Date: 2013-11-21 17:36:36 +0100 (Thu, 21 Nov 2013)
New Revision: 2726

Added:
   pkg/permute/R/update.Plots.R
   pkg/permute/R/update.how.R
Log:
add updated methods for classes 'how' and 'Plots'

Added: pkg/permute/R/update.Plots.R
===================================================================
--- pkg/permute/R/update.Plots.R	                        (rev 0)
+++ pkg/permute/R/update.Plots.R	2013-11-21 16:36:36 UTC (rev 2726)
@@ -0,0 +1,62 @@
+#  File permute/R/update.Plots.R
+#  Part of the R package, http://www.R-project.org
+#
+#  Copyright (C) 1995-2012 The R Core Team
+#
+#  This program is free software; you can redistribute it and/or modify
+#  it under the terms of the GNU General Public License as published by
+#  the Free Software Foundation; either version 2 of the License, or
+#  (at your option) any later version.
+#
+#  This program is distributed in the hope that it will be useful,
+#  but WITHOUT ANY WARRANTY; without even the implied warranty of
+#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+#  GNU General Public License for more details.
+#
+#  A copy of the GNU General Public License is available at
+#  http://www.r-project.org/Licenses/
+#
+# Modifications by Gavin L. Simpson
+#
+# Copyright (C) 2013 Gavin L. Simpson
+#
+# Modifcations made:
+#  1) Remove `formula.` argument and processing thereof.
+#  2) Evaluation is forced to the global environment.
+#  3) (minor) Took the definition of `call` out of the `if ()` statement
+#     for clarity/style issues.
+#  4) Added this modification section to the copyright/licence header.
+#  5) Added code to preserve some components of the original object.
+
+`update.Plots` <- function (object, ..., evaluate = TRUE) {
+    call <- getCall(object)
+    if (is.null(call))
+        stop("need an object with call component")
+    extras <- match.call(expand.dots = FALSE)$...
+
+    ## preserve or update the plots names
+    pname <- if ("strata" %in% names(extras)) {
+        deparse(substitute(extras[["strata"]]))
+    } else {
+        object$plots.name
+    }
+
+    if (length(extras)) {
+        existing <- !is.na(match(names(extras), names(call)))
+        ## do these individually to allow NULL to remove entries.
+        for (a in names(extras)[existing])
+            call[[a]] <- extras[[a]]
+        if (any(!existing)) {
+            call <- c(as.list(call), extras[!existing])
+            call <- as.call(call)
+        }
+    }
+    if (evaluate) {
+        out <- eval(call, parent.frame())
+        out$plots.name <- pname
+    } else {
+        out <- call
+    }
+
+    out
+}

Added: pkg/permute/R/update.how.R
===================================================================
--- pkg/permute/R/update.how.R	                        (rev 0)
+++ pkg/permute/R/update.how.R	2013-11-21 16:36:36 UTC (rev 2726)
@@ -0,0 +1,73 @@
+#  File permute/R/update.how.R
+#  Part of the R package, http://www.R-project.org
+#
+#  Copyright (C) 1995-2012 The R Core Team
+#
+#  This program is free software; you can redistribute it and/or modify
+#  it under the terms of the GNU General Public License as published by
+#  the Free Software Foundation; either version 2 of the License, or
+#  (at your option) any later version.
+#
+#  This program is distributed in the hope that it will be useful,
+#  but WITHOUT ANY WARRANTY; without even the implied warranty of
+#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+#  GNU General Public License for more details.
+#
+#  A copy of the GNU General Public License is available at
+#  http://www.r-project.org/Licenses/
+#
+# Modifications by Gavin L. Simpson
+#
+# Copyright (C) 2013 Gavin L. Simpson
+#
+# Modifcations made:
+#  1) Remove `formula.` argument and processing thereof.
+#  2) Evaluation is forced to the global environment.
+#  3) (minor) Took the definition of `call` out of the `if ()` statement
+#     for clarity/style issues.
+#  4) Added this modification section to the copyright/licence header.
+#  5) Added code to preserve some components of the original object.
+
+`update.how` <- function (object, ..., evaluate = TRUE) {
+    call <- getCall(object)
+    if (is.null(call))
+        stop("need an object with call component")
+    extras <- match.call(expand.dots = FALSE)$...
+
+    ## preserve or update block and/or plot  names
+    bname <- if ("blocks" %in% names(extras)) {
+        deparse(substitute(extras[["blocks"]]))
+    } else {
+        object$blocks.name
+    }
+    pname <- if ("plots" %in% names(extras)) {
+        dots <- list(...)
+        dots$plots$plots.name
+    } else {
+        object$plots$plots.name
+    }
+
+    ## process remaining ... args
+    if (length(extras)) {
+        existing <- !is.na(match(names(extras), names(call)))
+        ## do these individually to allow NULL to remove entries.
+        for (a in names(extras)[existing])
+            call[[a]] <- extras[[a]]
+        if (any(!existing)) {
+            call <- c(as.list(call), extras[!existing])
+            call <- as.call(call)
+        }
+    }
+
+    ## probably want to evaluate hence default is TRUE
+    if (evaluate) {
+        out <- eval(call, parent.frame())
+        ## add back in the chars we discovered earlier
+        out$blocks.name <- bname
+        out$plots$plots.name <- pname
+    } else {
+        out <- call
+    }
+
+    out
+}