[med-svn] [permute] 01/06: Imported Upstream version 0.8-3
Andreas Tille
tille at debian.org
Tue Jul 1 17:42:46 UTC 2014
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository permute.
commit e4bba3b5e737ea7fcfd5b25abe864e6a600b077f
Author: Andreas Tille <tille at debian.org>
Date: Tue Jul 1 17:39:54 2014 +0200
Imported Upstream version 0.8-3
---
DESCRIPTION | 13 ++--
MD5 | 16 +++--
R/allPerms.R | 76 ++++++++-------------
R/cbindAllPerms.R | 25 +++++++
R/setFoo-methods.R | 2 +-
data/jackal.rda | Bin 233 -> 233 bytes
inst/ChangeLog | 28 +++++++-
inst/doc/permutations.pdf | Bin 294805 -> 315861 bytes
inst/tests/test-allPerms.R | 127 ++++++++++++++++++++++++++++++++++++
tests/Examples/permute-Ex.Rout.save | 8 +--
10 files changed, 228 insertions(+), 67 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index e201012..e1f8849 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,7 +1,7 @@
Package: permute
Title: Functions for generating restricted permutations of data
-Version: 0.8-0
-Date: $Date: 2013-11-30 14:50:04 -0600 (Sat, 30 Nov 2013) $
+Version: 0.8-3
+Date: $Date$
Authors at R: c(person(given = "Gavin L.", family = "Simpson",
email = "ucfagls at gmail.com",
role = c("aut", "cph", "cre")),
@@ -15,12 +15,15 @@ License: GPL-2
ByteCompile: true
URL: http://vegan.r-forge.r-project.org/
Copyright: see file COPYRIGHTS
-Packaged: 2013-12-01 01:35:48 UTC; gavin
Author: Gavin L. Simpson [aut, cph, cre],
R Core Team [cph],
Douglas M. Bates [ctb],
Jari Oksanen [ctb]
Maintainer: Gavin L. Simpson <ucfagls at gmail.com>
-NeedsCompilation: no
Repository: CRAN
-Date/Publication: 2013-12-01 08:05:32
+Repository/R-Forge/Project: vegan
+Repository/R-Forge/Revision: 2847
+Repository/R-Forge/DateTimeStamp: 2014-01-28 04:02:29
+Date/Publication: 2014-01-29 21:24:58
+Packaged: 2014-01-28 07:15:34 UTC; rforge
+NeedsCompilation: no
diff --git a/MD5 b/MD5
index 1722635..58e639d 100644
--- a/MD5
+++ b/MD5
@@ -1,14 +1,15 @@
-d17d280d02b7b8ab6e0d36716c8b96d6 *DESCRIPTION
+c8e7612a0a63f74c04b864ce70dc8103 *DESCRIPTION
df79e949fde5fcf8262c64f61a36f563 *NAMESPACE
e868a91139fab764feebbf3590eb46e6 *R/Blocks.R
0d94016b600ddfd39087b8d41228ddb7 *R/Plots.R
40da812fd0c1530aa117d1677f707023 *R/Within.R
065086f18b59986e5feb8a6598b78632 *R/allFree.R
af6ec0ff884e97781072c6db2cdeb61b *R/allGrid.R
-78519ea751bd9a68a8f5fe183b28168b *R/allPerms.R
+8c9de52dc4507f15c1a8713b5544fd2a *R/allPerms.R
ed8d66f8de2f14fdee5ee0b4d7ca450e *R/allSeries.R
bfa5e00be181d197cab7b720faf825ef *R/allStrata.R
23435563d36be42bbd71da36581a78af *R/as.matrix.permutationMatrix.R
+8776e79c375b73cb5da9a72d507a6310 *R/cbindAllPerms.R
0b60312db5f277cc855239bfdf7ca3e1 *R/check.R
ab185e9fba9867b4e39969b331a7fcbc *R/fixupCall.R
ea0fed2f27a9ad36ffc707ede2837a00 *R/getFoo-methods.R
@@ -25,7 +26,7 @@ ec731b7d6b7ff91448b57b4d82f14237 *R/permCheck.R
04a88532586e8f7b20dfca3697444184 *R/print.permutationMatrix.R
ad976cbddacaaaebd1e3b5a6f4eba771 *R/print.summary.allPerms.R
eb6d20a84325371ed25f56333a1286f0 *R/print.summary.check.R
-9e4ebf15084c8b312302e50cf75822ed *R/setFoo-methods.R
+ba89b1916be6bb7dca85db896f17ed97 *R/setFoo-methods.R
270abfbd5c6dd686dcd7153c7b8a7233 *R/shuffle-utils.R
5af7a108e95967ff093997c5e526f15c *R/shuffle.R
39c8c45fd10de34925fd3ba1c72c5b3f *R/shuffle2.R
@@ -36,14 +37,15 @@ be4f5fe71b76835e41ef76ce3c08cb26 *R/shuffleSet2.R
33064923b08d1e65469449f32b0f2797 *R/update.Plots.R
3a2a885a7705cee2fd97ecc1a7238b12 *R/update.how.R
caa68989ef55fad314f0a42b5404b8ba *build/vignette.rds
-4d966dbdda958c863064462aeb589708 *data/jackal.rda
+32e245d3377acee42723730435dac8ea *data/jackal.rda
aa947360198890f9a747920d52cf52c2 *inst/COPYRIGHTS
-fd065b9d310a6fcb0eaff8a4c3616508 *inst/ChangeLog
+981143d625263b8bd8379c18b3eb4500 *inst/ChangeLog
f18d13fa109c9f1313a2164ee057d358 *inst/NEWS.Rd
bbb242b30032dba5f5a775dc43e91bf7 *inst/TODO.md
37b4278adbb6c6106e2cfe5be5de0840 *inst/doc/permutations.R
82da16c514a05f417eb5a67d36270221 *inst/doc/permutations.Rnw
-6ece0d36edc8254b7e9f42716263f7ca *inst/doc/permutations.pdf
+e5d809af130e40a08ba38ff89286e79a *inst/doc/permutations.pdf
+810129beac4ad79366a1936d2b92c331 *inst/tests/test-allPerms.R
712bed4b9184a5857cb8633574a70a87 *inst/tests/test-check.R
8714401ccd2ba7fff8f5d423fdb700be *inst/tests/test-shuffle.R
d0c240b14dca251488275ea5f84e5110 *inst/tests/test-shuffleSet.R
@@ -62,7 +64,7 @@ e69cb80138b5b21371a7a3719b610949 *man/set-methods.Rd
74e0599d75011a519bd917481f0df308 *man/shuffle-utils.Rd
eb210047aa7f8feb8bda0d1afc191111 *man/shuffle.Rd
f3ec8abb06c4f2ced18dfa7944db8846 *man/shuffleSet.Rd
-a605ebe1bb996bfc81e14b5b97a63d09 *tests/Examples/permute-Ex.Rout.save
+74a1cad479e409192c045657b5801607 *tests/Examples/permute-Ex.Rout.save
8f3e383676a96e96a4f5e56e93c6e131 *tests/test-all.R
51dfb25079d9f14d40896092d96e277d *vignettes/Z.cls
82da16c514a05f417eb5a67d36270221 *vignettes/permutations.Rnw
diff --git a/R/allPerms.R b/R/allPerms.R
index 3227b54..985c07e 100644
--- a/R/allPerms.R
+++ b/R/allPerms.R
@@ -60,9 +60,12 @@
nperms = nperms)
}
+ ## bind all blocks together, repeating them as required
+ out <- cbindAllPerms(out)
+
## bind all the blocks together
- out <- do.call(cbind, out) ## hmm are any of these the same shape?
- out[, unlist(spl)] <- out
+ ## out <- do.call(cbind, out) ## hmm are any of these the same shape?
+ out[, unlist(spl)] <- out ## is this being done at the doAllPerms level?
if(!(observed <- getObserved(control))) {
obs.v <- seq_len(n)
@@ -72,7 +75,7 @@
## observed ordering
setNperm(control) <- getNperm(control) - 1
}
- class(out) <- "allPerms"
+ class(out) <- c("allPerms", "matrix")
attr(out, "control") <- control
attr(out, "observed") <- observed
out
@@ -81,12 +84,6 @@
`doAllPerms` <- function(obs, strataP, typeW, typeP, mirrorW, mirrorP,
constantW, dimW, dimP, control, nperms) {
- ## replicate a matrix by going via a list and bind together
- repMat <- function(mat, n) {
- res <- rep(list(mat), n)
- do.call(rbind, res)
- }
-
n <- length(obs)
## subset strataP to take only the obs indices and drop the unused
@@ -98,6 +95,9 @@
## also need to update the $strata component of control
## FIXME: this really should have a toplevel function to set/update
## sub-components of control
+ ## Pl <- getPlots(control)
+ ## setStrata(Pl) <- strataP
+ ## setPlots(control) <- Pl
control$plots$strata <- strataP
## permuting within?
@@ -109,13 +109,15 @@
series = allSeries(n, nperms, mirrorW),
grid = allGrid(n, nperms, dimW[1],
dimW[2], mirrorW, constantW))
+ ## use res to index original observation indices in this group
+ res[] <- obs[res]
} else {
## permuting within plots
tab <- table(strataP)
pg <- unique(tab)
+ ng <- length(tab)
if(constantW) {
## same permutation in each plot
- ##pg <- unique(tab)
controlW <- how(within = getWithin(control))
nperms <- numPerms(pg, controlW)
ord <- switch(typeW,
@@ -123,19 +125,19 @@
series = allSeries(pg, nperms, mirrorW),
grid = allGrid(pg, nperms, dimW[1],
dimW[2], mirrorW, constantW))
- permW <- nrow(ord)
- sp <- split(obs, strataP)
- res <- matrix(nrow = nperms, ncol = n)
- for(i in seq_len(permW)) {
- res[i,] <- sapply(sp,
- function(x, ord) x[ord[i,]], ord = ord)
+ res <- vector(mode = "list", length = ng)
+ ss <- seq(0, to = prod(pg, ng-1), by = pg)
+ for (i in seq_len(ng)) {
+ res[[i]] <- ord + ss[i]
}
+ ## same permutation within plots, so just cbind rather than
+ ## cbindAllPerms as we don't need all combns of rows
+ res <- do.call(cbind, res)
+ res[] <- obs[res] ## index into the observations in this block
} else {
## different permutations within plots
nperms <- numPerms(sum(tab), control)
- ng <- length(tab)
- ##pg <- unique(tab)
if(length(pg) > 1) {
## different number of observations per level of strata
if(typeW == "grid")
@@ -143,7 +145,6 @@
## in place in check()
stop("Unbalanced grid designs are not supported")
controlW <- how(within = getWithin(control))
- sp <- split(obs, strataP)
res <- vector(mode = "list", length = ng)
add <- c(0, cumsum(tab)[1:(ng-1)])
for(j in seq_along(tab)) {
@@ -151,23 +152,10 @@
ord <- switch(typeW,
free = allFree(tab[j]),
series = allSeries(tab[j], np, mirrorW))
- permW <- nrow(ord)
- if(j == 1) {
- a <- 1
- b <- nperms / np
- } else {
- b <- b / np
- a <- nperms / (b * np)
- }
- res[[j]] <- matrix(rep(repMat(ord+add[j], a),
- each = b),
- ncol = tab[j])
+ res[[j]] <- ord + add[j]
}
- res <- do.call(cbind, res)
- sp <- split(obs, strataP)
- res <- t(apply(res, 1,
- function(x, inds, o) {o[inds] <- inds[x]; o},
- unlist(sp), obs))
+ res <- cbindAllPerms(res)
+ res[] <- obs[res]
} else {
## same number of observations per level of strata
controlW <- how(within = getWithin(control))
@@ -178,23 +166,13 @@
series = allSeries(pg, np, mirrorW),
grid = allGrid(pg, np, dimW[1],
dimW[2], mirrorW, constantW))
- permW <- nrow(ord)
- add <- seq(from = 0, by = pg, length.out = ng)
res <- vector(mode = "list", length = ng)
- a <- 1
- b <- np / permW
+ ss <- seq(0, to = prod(pg, ng-1), by = pg)
for(i in seq_len(ng)) {
- res[[i]] <- matrix(rep(repMat(ord+add[i], a),
- each = b),
- ncol = pg)
- a <- a*permW
- b <- b/permW
+ res[[i]] <- ord + ss[i]
}
- res <- do.call(cbind, res)
- sp <- split(obs, strataP)
- res <- t(apply(res, 1,
- function(x, inds, o) {o[inds] <- inds[x]; o},
- unlist(sp), obs))
+ res <- cbindAllPerms(res)
+ res[] <- obs[res]
}
}
}
diff --git a/R/cbindAllPerms.R b/R/cbindAllPerms.R
new file mode 100644
index 0000000..fd62661
--- /dev/null
+++ b/R/cbindAllPerms.R
@@ -0,0 +1,25 @@
+##' @title Replicate and cbind all block-level permutations
+##' @param x a list whose compontents are the set of all permutations
+##' at the block level
+##' @return a matrix
+##' @author Gavin L. Simpson
+`cbindAllPerms` <- function(x) {
+ nb <- length(x) ## number of blocks
+
+ ## allPerms has first block varying slowest, but expand.grid has
+ ## first factor varying fastest. Hence we reverse `x` here, and
+ ## also reverse `out` back again later
+ x <- rev(x)
+
+ ## prepares nb seqence vectors 1:`obs in block` for expand.grid
+ rowind <- do.call(expand.grid,
+ lapply(x, function(i) seq_len(nrow(i))))
+
+ ## index elements of x using the row indices - gives a list to cbind
+ ## next. sapply() over-simplifies to wrong dimensions so not used.
+ ## Note: the lapply() result is reversed with `rev` to undo the reversing
+ ## of `x` earlier; ensures everything is correct block order.
+ out <- rev(lapply(seq_len(nb), function(i, m, ind) m[[i]][ind[, i] ,],
+ m = x, ind = rowind))
+ do.call(cbind, out) ## return
+}
diff --git a/R/setFoo-methods.R b/R/setFoo-methods.R
index a4da3f5..008c7fd 100644
--- a/R/setFoo-methods.R
+++ b/R/setFoo-methods.R
@@ -141,10 +141,10 @@
}
`setBlocks<-.how` <- function(object, value) {
+ object[["blocks.name"]] <- deparse(substitute(value))
if (!is.null(value))
value <- as.factor(value)
object["blocks"] <- list(value)
- object[["blocks.name"]] <- deparse(substitute(value))
object <- fixupCall(object, "blocks", value)
object
}
diff --git a/data/jackal.rda b/data/jackal.rda
index 590f391..a2c6f52 100644
Binary files a/data/jackal.rda and b/data/jackal.rda differ
diff --git a/inst/ChangeLog b/inst/ChangeLog
index 00111f1..00406bf 100644
--- a/inst/ChangeLog
+++ b/inst/ChangeLog
@@ -1,7 +1,33 @@
-$Date: 2013-11-30 17:32:45 -0600 (Sat, 30 Nov 2013) $
+$Date: 2014-01-26 20:21:11 +0100 (Sun, 26 Jan 2014) $
permute ChangeLog
+Version 0.8-3
+
+ * allPerms: with free permutations *within* plots, `allPerms()`
+ was not returning the indices in the original data but in the
+ permutation indices within plots.
+
+ Reported by: Joris Meys
+
+Version 0.8-2
+
+ * allPerms: with free permutations *within* blocks, `allPerms()`
+ was not returning the indices in the original data but in the
+ permutation indices within block.
+
+ In addition, `allPerms()` was not replicating each row in a
+ within-block permutation matrix for all the rows in the other
+ block within-block permutation matrices. This is now achieved via
+ a new, non-exported utility function `cbindAllPerms()`.
+
+ Reported by: Joris Meys
+
+Version 0.8-1
+
+ * setBlocks: get block name before doing anything so that you
+ really get only name instead of its evaluated value.
+
Version 0.8-0
* Released to CRAN
diff --git a/inst/doc/permutations.pdf b/inst/doc/permutations.pdf
index 0047d40..ce6d856 100644
Binary files a/inst/doc/permutations.pdf and b/inst/doc/permutations.pdf differ
diff --git a/inst/tests/test-allPerms.R b/inst/tests/test-allPerms.R
new file mode 100644
index 0000000..28f183f
--- /dev/null
+++ b/inst/tests/test-allPerms.R
@@ -0,0 +1,127 @@
+library(testthat)
+library_if_available(permute)
+
+context("Testing allPerms()")
+
+test_that("allPerms - blocks - within block free", {
+ ## example data from Joris Meys from
+ ## http://stackoverflow.com/a/21313632/429846
+ thedata <- data.frame(score = c(replicate(4, sample(1:3))),
+ judge = rep(1:4, each = 3),
+ wine = rep.int(1:3, 4))
+
+ ## without the observed permutation included
+ hh <- how(within = Within("free"),
+ blocks = factor(thedata$judge),
+ complete = TRUE, maxperm = 1e9)
+ nr <- nrow(thedata)
+ np <- numPerms(nr, hh)
+ p <- allPerms(nr, control = hh)
+ expect_that(nrow(p), equals(np - 1)) ## default is to drop observed
+
+ ## check no duplicate indices within rows
+ dup <- any(apply(p, 1, function(x) any(duplicated(x))))
+ expect_false(dup, info = "Blocks: even; within: free; no observed")
+
+ ## with the observed permutation included
+ hh <- how(within = Within("free"),
+ blocks = factor(thedata$judge),
+ complete = TRUE, maxperm = 1e9,
+ observed = TRUE)
+ p <- allPerms(nr, control = hh)
+ expect_that(nrow(p), equals(np)) ## now includes observed
+
+ ## check no duplicate indices within rows
+ dup <- any(apply(p, 1, function(x) any(duplicated(x))))
+ expect_false(dup, info = "Blocks: even; within: free; observed")
+})
+
+test_that("allPerms; blocks: within; block free - uneven block sizes", {
+ fac <- factor(rep(1:3, times = c(2,2,4)))
+
+ ## without the observed permutation included
+ hh <- how(within = Within("free"),
+ blocks = fac,
+ complete = TRUE, maxperm = 1e9)
+ ll <- length(fac)
+ np <- numPerms(ll, hh)
+ expect_that(np, equals(prod(factorial(2), factorial(2), factorial(4))))
+ p <- allPerms(ll, control = hh)
+ expect_that(nrow(p), equals(np - 1)) ## default is to drop observed
+
+ ## check no duplicate indices within rows
+ dup <- any(apply(p, 1, function(x) any(duplicated(x))))
+ expect_false(dup, info = "Blocks: uneven; within: free; no observed")
+
+ ## with the observed permutation included
+ hh <- how(within = Within("free"),
+ blocks = fac,
+ complete = TRUE, maxperm = 1e9,
+ observed = TRUE)
+ p <- allPerms(ll, control = hh)
+ expect_that(nrow(p), equals(np)) ## now includes observed
+
+ ## check no duplicate indices within rows
+ dup <- any(apply(p, 1, function(x) any(duplicated(x))))
+ expect_false(dup, info = "Blocks: uneven; within: free; observed")
+})
+
+## testing plot-level permutations ------------------------------------
+test_that("allPerms: plots; within: free; even: yes;", {
+ fac <- rep(1:3, each = 3)
+
+ hh <- how(plots = Plots(strata = fac),
+ complete = TRUE, maxperm = 1e9)
+ ll <- length(fac)
+ np <- numPerms(ll, hh)
+ p <- allPerms(ll, control = hh)
+ expect_that(nrow(p), equals(np - 1), ## default is to drop observed
+ info = "Check n all perms == numPerms output.")
+
+ ## check no duplicate indices within rows
+ dup <- any(apply(p, 1, function(x) any(duplicated(x))))
+ expect_false(dup,
+ info = "Unique? Plots: even; within: free; no observed")
+
+ ## with the observed permutation included
+ hh <- how(within = Within("free"),
+ plot = Plots(strata = fac),
+ complete = TRUE, maxperm = 1e9,
+ observed = TRUE)
+ p <- allPerms(ll, control = hh)
+ expect_that(nrow(p), equals(np)) ## now includes observed
+
+ ## check no duplicate indices within rows
+ dup <- any(apply(p, 1, function(x) any(duplicated(x))))
+ expect_false(dup, info = "Unique? Plots: even; within: free; inc observed")
+})
+
+test_that("allPerms; plots: within; plot free - uneven plot sizes", {
+ fac <- factor(rep(1:3, times = c(2,2,4)))
+
+ ## without the observed permutation included
+ hh <- how(within = Within("free"),
+ plots = Plots(strata = fac),
+ complete = TRUE, maxperm = 1e9)
+ ll <- length(fac)
+ np <- numPerms(ll, hh)
+ expect_that(np, equals(prod(factorial(2), factorial(2), factorial(4))))
+ p <- allPerms(ll, control = hh)
+ expect_that(nrow(p), equals(np - 1)) ## default is to drop observed
+
+ ## check no duplicate indices within rows
+ dup <- any(apply(p, 1, function(x) any(duplicated(x))))
+ expect_false(dup, info = "Plots: uneven; within: free; no observed")
+
+ ## with the observed permutation included
+ hh <- how(within = Within("free"),
+ plots = Plots(strata = fac),
+ complete = TRUE, maxperm = 1e9,
+ observed = TRUE)
+ p <- allPerms(ll, control = hh)
+ expect_that(nrow(p), equals(np)) ## now includes observed
+
+ ## check no duplicate indices within rows
+ dup <- any(apply(p, 1, function(x) any(duplicated(x))))
+ expect_false(dup, info = "Plots: uneven; within: free; observed")
+})
diff --git a/tests/Examples/permute-Ex.Rout.save b/tests/Examples/permute-Ex.Rout.save
index 3fae873..701a614 100644
--- a/tests/Examples/permute-Ex.Rout.save
+++ b/tests/Examples/permute-Ex.Rout.save
@@ -1,6 +1,6 @@
-R version 3.0.2 Patched (2013-09-26 r64005) -- "Frisbee Sailing"
-Copyright (C) 2013 The R Foundation for Statistical Computing
+R version 3.0.2 Patched (2014-01-14 r64768) -- "Frisbee Sailing"
+Copyright (C) 2014 The R Foundation for Statistical Computing
Platform: x86_64-unknown-linux-gnu (64-bit)
R is free software and comes with ABSOLUTELY NO WARRANTY.
@@ -207,7 +207,7 @@ Contains observed ordering?: No
> require(vegan)
Loading required package: vegan
Loading required package: lattice
-This is vegan 2.1-37
+This is vegan 2.0-10
> example(pyrifos)
pyrifs> data(pyrifos)
@@ -1207,7 +1207,7 @@ Restricted by Plots: gl(4, 5) (4 plots)
> ###
> options(digits = 7L)
> base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n")
-Time elapsed: 2.288 0.038 2.347 0 0
+Time elapsed: 2.257 0.042 2.373 0 0
> grDevices::dev.off()
null device
1
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/permute.git
More information about the debian-med-commit
mailing list