Nothing
tests/testthat/testSources.r
In dae: Functions Useful in the Design and ANOVA of Experiments
#devtools::test("dae")
context("canonical")
cat("#### Test for source formation\n")
test_that("sources", {
skip_on_cran()
library(dae)
#((A*B)/C)*D
ABCD.lay <- fac.gen(list(A = 3, B = 3, C = 3, D = 3))
ABCD.struct <- pstructure(~ ((A*B)/C)*D, labels = "sources", data =ABCD.lay)
ABCD.dat <- as.data.frame(ABCD.struct)
testthat::expect_equal(names(ABCD.struct$Q), ABCD.dat$sources)
testthat::expect_equal(ABCD.dat$sources,
c("A","B","A#B","C[A:B]","D","A#D","B#D","A#B#D","C#D[A:B]"))
ABCD.struct <- pstructure(~ ((A*B)/C)*D, omit.projectors = TRUE, labels = "terms", data =ABCD.lay)
ABCD.dat <- as.data.frame(ABCD.struct)
testthat::expect_equal(ABCD.dat$df, c(2,2,4,18,2,4,4,8,36))
#Generalized factor crossed with others
genfac1.lay <- fac.gen(list(S = 3, A = 3, D = 3))
gf1.struct <- pstructure(~ (S:A)*D, labels = "sources", data =genfac1.lay)
testthat::expect_equal(unname(gf1.struct$sources), c("S:A","D","(S:A)#D"))
#Generalized factor nested within another factor
gf2.struct <- pstructure(~ D/(S:A), labels = "sources", data =genfac1.lay)
testthat::expect_equal(unname(gf2.struct$sources), c("D","S:A[D]"))
#Generalized factor nesting another factor
gf3.struct <- pstructure(~ (S:A)/D, labels = "sources", data =genfac1.lay)
testthat::expect_equal(unname(gf3.struct$sources), c("S:A","D[S:A]"))
#Two generalized factor nested within another and each other
genfac4.lay <- fac.gen(list(S = 3, A = 3, D = 3, B = 3, C = 3))
gf4.struct <- pstructure(~ D/(S:A)/(B:C), labels = "sources", data =genfac4.lay)
testthat::expect_equal(unname(gf4.struct$sources), c("D","S:A[D]","B:C[D:S:A]"))
#Two generalized factor nested within another and each other - add grand mean
gf4gm.struct <- pstructure(~ D/(S:A)/(B:C), labels = "sources", grandMean = TRUE, data =genfac4.lay)
testthat::expect_equal(unname(gf4gm.struct$sources), c("Mean", "D","S:A[D]","B:C[D:S:A]"))
testthat::expect_equal(nrow(as.data.frame(gf4gm.struct, omit.marginality = TRUE)), 4)
#Single term
one.struct <- pstructure(~ D, labels = "sources", data =genfac4.lay)
#Single term with grand mean
one.struct <- pstructure(~ D, labels = "sources", grandMean = TRUE, data =genfac4.lay)
testthat::expect_equal(unname(one.struct$terms), c("Mean", "D"))
testthat::expect_equal(unname(one.struct$sources), c("Mean", "D"))
testthat::expect_equal(nrow(as.data.frame(one.struct, omit.marginality = TRUE)), 2)
})
cat("#### Test for designAnatomy for Thao designs\n")
test_that("Thao", {
skip_on_cran()
library(dae)
Br <- 4
Bc <- 4
Sr<-4
Sc<-4
n <- Sr*Sc*Br*Bc
v<- 4
s<-4
##### Poset 2f design 2
# Factor D and E are latinised using LCCD.
LS1 <- factor(c(1:4, 4:1, 2,1,4,3,3,4,1,2 ))
LS2 <- factor(c(1:4,2,1,4,3,3,4,1,2,4,3,2,1 ))
LS3 <- factor(c(1:4, 3,4,1,2, 4:1, 2,1,4,3))
LS4 <- factor(c(1:4, 2,1,4,3, 3,4,1,2, 4:1))
LS4.CC4x4.2f.ran <- data.frame(
A = factor(c(rep(c(1,2,1,2 ,2,1,2,1 ,1,2,1,2 ,2,1,2,1), each=16))),
B = factor(c(rep(c(1,1,2,2 ,1,1,2,2 ,2,2,1,1 ,2,2,1,1), each=16))),
D = factor(c(rep(LS1[1:4],each=4), rep(LS1[5:8],each=4),rep(LS1[9:12],each=4),rep(LS1[13:16],each=4)
,rep(LS2[1:4],each=4), rep(LS2[5:8],each=4),rep(LS2[9:12],each=4),rep(LS2[13:16],each=4)
,rep(LS3[1:4],each=4), rep(LS3[5:8],each=4),rep(LS3[9:12],each=4),rep(LS3[13:16],each=4)
,rep(LS4[1:4],each=4), rep(LS4[5:8],each=4),rep(LS4[9:12],each=4),rep(LS4[13:16],each=4))),
E = factor(c(rep(LS1[1:4],times=4),rep(LS2[1:4],times=4),rep(LS3[1:4],times=4),rep(LS4[1:4],times=4)
,rep(LS1[5:8],times=4), rep(LS2[5:8],times=4), rep(LS3[5:8],times=4),rep(LS4[5:8],times=4)
,rep(LS1[9:12],times=4),rep(LS2[9:12],times=4),rep(LS3[9:12],times=4),rep(LS4[9:12],times=4)
,rep(LS1[13:16],times=4),rep(LS2[13:16],times=4),rep(LS3[13:16],times=4) ,rep(LS4[13:16],times=4))))
#generate layout
LS4.CC4x4.2f.lay <- designRandomize(allocated=LS4.CC4x4.2f.ran,
recipient = list(BigRows= Br, BigColumns=Bc, Rows=Sr, Columns=Sc),
nested.recipients = list(Columns="BigColumns", Rows="BigRows"),
seed = 550)
#Compute anatomy
LS4.CC4x4.2f.canon <- designAnatomy(list(unit = ~ (BigRows/Rows)*(BigColumns/Columns),
trt = ~ A*B*D*E),
data = LS4.CC4x4.2f.lay)
testthat::expect_true(all(LS4.CC4x4.2f.canon$sources$unit ==
c("BigRows", "Rows[BigRows]", "BigColumns", "Columns[BigColumns]",
"BigRows#BigColumns", "BigRows#Columns[BigColumns]",
"Rows#BigColumns[BigRows]", "Rows#Columns[BigRows:BigColumns]")))
summary(LS4.CC4x4.2f.canon, which.criteria = c("aeff", "xeff", "eeff", "order"))
#### Poset 3c, design 1 - an N-poset
#Set up allocated factors
LS4.CC4x4.3c.ran <- cbind(data.frame(A = factor(rep(c(1,1,2,2 ,1,1,2,2 ,2,2,1,1 ,2,2,1,1), each = 16)),
B = factor(rep(c(1,2,1,2 ,2,1,2,1 ,1,2,1,2 ,2,1,2,1), each = 16))),
fac.gen(list(D = 4, E = 4), times = 16))
#generate layout and analyze
LS4.CC4x4.3c.lay <- designRandomize(allocated=LS4.CC4x4.3c.ran,
recipient = list(BigRows= Br, BigColumns=Bc, Rows=Sr, Columns=Sc),
nested.recipients = list(Rows="BigRows", Columns=c("BigRows","BigColumns")),
seed = 550)
#Compute anatomy
LS4.CC4x4.3c.canon <- designAnatomy(list(unit = ~ (BigRows/Rows)*BigColumns +((BigColumns*BigRows)/Columns)/Rows,
trt = ~ A*B*D*E),
data =LS4.CC4x4.3c.lay)
testthat::expect_true(all(LS4.CC4x4.3c.canon$sources$unit ==
c("BigRows", "Rows[BigRows]", "BigColumns", "BigRows#BigColumns",
"Rows#BigColumns[BigRows]", "Columns[BigRows:BigColumns]",
"Rows#Columns[BigRows:BigColumns]")))
summary(LS4.CC4x4.3c.canon, which.criteria = c("aeff", "order"))
### Poset 4a
LS4x4.CC5x5.4a.ran <- cbind(data.frame(A = factor(rep(c(1,2,1,2 ,2,1,2,1 ,1,2,1,2 ,2,1,2,1), each = 16)),
B = factor(rep(c(1,1,2,2 ,1,1,2,2 ,2,2,1,1 ,2,2,1,1), each = 16))),
fac.gen(list(D = 4, E = 4), times = 16))
#generate layout and analyze
LS4x4.CC5x5.4a.lay <- designRandomize(allocated=LS4x4.CC5x5.4a.ran,
recipient = list(BigRows= Br, BigColumns=Bc, Rows=Sr, Columns=Sc),
nested.recipients = list(Columns=c("BigRows","BigColumns"),
Rows=c("BigRows","BigColumns")),
seed = 690)
#Compute anatomy
LS4x4.CC5x5.4a.lcanon <- designAnatomy(list(unit = ~ (BigRows*BigColumns)/(Rows*Columns),
trt = ~ A*B*D*E),
data =LS4x4.CC5x5.4a.lay)
testthat::expect_true(all(LS4x4.CC5x5.4a.lcanon$sources$unit ==
c("BigRows", "BigColumns", "BigRows#BigColumns", "Rows[BigRows:BigColumns]",
"Columns[BigRows:BigColumns]", "Rows#Columns[BigRows:BigColumns]")))
summary(LS4x4.CC5x5.4a.lcanon, which.criteria = c("aeff", "order"))
})
cat("#### Test for designAnatomy with sources and marginality using Cochran&Cox PBIBD2\n")
test_that("PBIBD2_sources", {
skip_on_cran()
library(dae)
#'# PBIBD(2) from p. 379 of Cochran and Cox (1957) Experimental Designs. 2nd edn Wiley, New York"
#'## Input the design and randomize"
Treatments <- factor(c(1,4,2,5, 2,5,3,6, 3,6,1,4, 4,1,5,2, 5,2,6,3, 6,3,4,1))
PBIBD2.lay <- designRandomize(allocated = Treatments,
recipient = list(Blocks =6, Units = 4),
nested.recipients = list(Units = "Blocks"),
seed = 98177)
#'## Test that projs.canon has been deprecated
testthat::expect_warning(PBIBD2.canon <-
projs.canon(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
which.criteria = c('aeff', 'xeff', 'eeff','order'),
labels = "sources", data = PBIBD2.lay))
#'##By differencing
PBIBD2D.canon <-
designAnatomy(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
which.criteria = c('aeff', 'xeff', 'eeff','order'),
labels = "sources", orthogonalize = "diff", data = PBIBD2.lay)
summary(PBIBD2D.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_equal(PBIBD2D.canon$Q[[1]]$Blocks$Treatments$adjusted$aefficiency, 0.25)
testthat::expect_lt(abs(PBIBD2D.canon$Q[[1]]$'Units[Blocks]'$Treatments$adjusted$aefficiency - 0.8824), 1e-04)
testthat::expect_equal(PBIBD2D.canon$Q[[2]]$'Blocks&Treatments', 2)
testthat::expect_equal(PBIBD2D.canon$Q[[2]]$'Blocks&Residual', 3)
testthat::expect_equal(PBIBD2D.canon$Q[[2]]$'Units[Blocks]&Treatments', 5)
testthat::expect_equal(PBIBD2D.canon$Q[[2]]$'Units[Blocks]&Residual', 13)
testthat::expect_lt(abs(PBIBD2D.canon$Q[[1]]$'Units[Blocks]'$Treatments$adjusted$aefficiency -
0.8824), 1e-04)
testthat::expect_null(PBIBD2D.canon$aliasing$unit)
testthat::expect_null(PBIBD2D.canon$aliasing$trt)
PBIBD2.marg <- PBIBD2D.canon$marginality
#'##By differencing with grand mean
PBIBD2Dg.canon <-
designAnatomy(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
grandMean = TRUE, labels = "sources", orthogonalize = "diff",
which.criteria = c('aeff', 'xeff', 'eeff','order'),
data = PBIBD2.lay)
summary(PBIBD2Dg.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_equal(PBIBD2Dg.canon$Q[[2]]$`Mean&Mean`, 1)
#'##By eigenmethods
PBIBD2E.canon <-
designAnatomy(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
which.criteria = c('aeff', 'xeff', 'eeff','order'),
labels = "sources", orthogonalize = "eigen", data = PBIBD2.lay)
summary(PBIBD2E.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_true(attr(PBIBD2E.canon, which = "labels") == "terms")
testthat::expect_lt(abs(PBIBD2E.canon$Q[[1]]$'Blocks:Units'$Treatments$adjusted$aefficiency -
0.8824), 1e-04)
#'##By eigenmethods with supplied marginality
PBIBD2Em.canon <-
designAnatomy(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
marginality = PBIBD2D.canon$marginality,
which.criteria = c('aeff', 'xeff', 'eeff','order'),
labels = "sources", orthogonalize = "eigen", data = PBIBD2.lay)
summary(PBIBD2Em.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_equal(length(PBIBD2Em.canon$marginality), 2)
testthat::expect_true(attr(PBIBD2Em.canon, which = "labels") == "sources")
#marginality list with trt NULL - same as supplying just unit marginality
PBIBD2Em.canon <-
designAnatomy(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
marginality = PBIBD2.marg,
which.criteria = c('aeff', 'xeff', 'eeff','order'),
labels = "sources", orthogonalize = "eigen", data = PBIBD2.lay)
summary(PBIBD2Em.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_equal(length(PBIBD2Em.canon$marginality), 2)
testthat::expect_true(attr(PBIBD2Em.canon, which = "labels") == "sources")
#full marginality list
PBIBD2Em.canon <-
designAnatomy(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
marginality = PBIBD2.marg,
which.criteria = c('aeff', 'xeff', 'eeff','order'),
labels = "sources", orthogonalize = "eigen", data = PBIBD2.lay)
summary(PBIBD2Em.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_equal(length(PBIBD2Em.canon$marginality), 2)
testthat::expect_true(attr(PBIBD2Em.canon, which = "labels") == "sources")
testthat::expect_true(all(names(PBIBD2Em.canon$marginality) == names(PBIBD2.marg)))
testthat::expect_lt(abs(PBIBD2Em.canon$Q[[1]]$'Units[Blocks]'$Treatments$adjusted$aefficiency -
0.8824), 1e-04)
#Add grand mean term
PBIBD2Egm.canon <-
designAnatomy(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
grandMean = TRUE, marginality = PBIBD2.marg,
which.criteria = c('aeff', 'xeff', 'eeff','order'),
labels = "sources", orthogonalize = "eigen", data = PBIBD2.lay)
summary(PBIBD2Egm.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_equal(length(PBIBD2Em.canon$marginality), 2)
testthat::expect_true(attr(PBIBD2Em.canon, which = "labels") == "sources")
testthat::expect_true(all(PBIBD2Egm.canon$terms$unit == c("Mean", "Blocks", "Blocks:Units")))
testthat::expect_true(all(PBIBD2Egm.canon$terms$trt == c("Mean", "Treatments")))
testthat::expect_true(all(names(PBIBD2Em.canon$marginality) == names(PBIBD2.marg)))
testthat::expect_lt(abs(PBIBD2Em.canon$Q[[1]]$'Units[Blocks]'$Treatments$adjusted$aefficiency -
0.8824), 1e-04)
#'## unique plot levels
PBIBD2.lay$AUnits <- with(PBIBD2.lay, fac.combine(list(Blocks,Units)))
PBIBD2A.canon <- designAnatomy(list(unit = ~Blocks + AUnits,
trt = ~ Treatments),
data = PBIBD2.lay, labels = "sources",
which.criteria = c('aeff', 'xeff', 'eeff','order'),
orthogonalize = "hybrid")
summary(PBIBD2A.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_lt(abs(PBIBD2A.canon$Q[[1]]$'AUnits[Blocks]'$Treatments$adjusted$aefficiency -
0.8824), 1e-04)
})
cat("#### Test for Jarrett & Ruggiero example\n")
test_that("JarrettRuggiero", {
skip_on_cran()
library(dae)
#'## Jarrett & Ruggiero example
jr.lay <- fac.gen(list(Set=7, Dye=2, Array=3))
jr.lay <- within(jr.lay,
{ Block <- factor(rep(1:7, each=6))
Plant <- factor(rep(c(1,2,3,2,3,1), times=7))
Sample <- factor(c(rep(c(2,1,2,2,1,1, 1,2,1,1,2,2), times=3), 2,1,2,2,1,1))
S1 <- Dye
Treat <- factor(c(1,2,4,2,4,1, 2,3,5,3,5,2, 3,4,6,4,6,3, 4,5,7,5,7,4,
5,6,1,6,1,5, 6,7,2,7,2,6, 7,1,3,1,3,7),
labels=c("A","B","C","D","E","F","G"))
})
array.plot.trt.canon <- designAnatomy(formulae = list(array = ~ (Set:Array)*Dye,
plot = ~ Block/Plant/Sample,
trt = ~ Treat),
labels = "sources", data = jr.lay)
testthat::expect_equal(length(array.plot.trt.canon$Q[[3]]), 7)
testthat::expect_equal(array.plot.trt.canon$Q[[3]]$`(Set:Array)#Dye&Sample[Block:Plant]`, 6)
testthat::expect_lt(abs(array.plot.trt.canon$Q[[2]]$`(Set:Array)#Dye&Plant[Block]`$Treat$adjusted$aefficiency - 0.58333333), 1e-05)
testthat::expect_lt(abs(array.plot.trt.canon$Q[[1]]$`(Set:Array)#Dye`$`Plant[Block]`$adjusted$aefficiency - 0.75), 1e-05)
summ.default <-summary(array.plot.trt.canon)
testthat::expect_equal(nrow(summ.default$decomp), 7)
testthat::expect_equal(ncol(summ.default$decomp), 9)
testthat::expect_false(is.null(attr(summ.default$aliasing, which = "title")))
summ.none <-summary(array.plot.trt.canon, which.criteria = "none")
testthat::expect_equal(ncol(summ.none$decomp), 6)
summ.all <-summary(array.plot.trt.canon, which.criteria = "all")
testthat::expect_equal(ncol(summ.all$decomp), 13)
summ.2 <-summary(array.plot.trt.canon, which.criteria =c("aefficiency", "order"))
testthat::expect_equal(ncol(summ.2$decomp), 8)
#with grand mean
apt.gm.canon <- designAnatomy(formulae = list(array = ~ (Set:Array)*Dye,
plot = ~ Block/Plant/Sample,
trt = ~ Treat),
grandMean = TRUE, labels = "sources", data = jr.lay)
summary(apt.gm.canon)
testthat::expect_equal(apt.gm.canon$Q[[3]]$`Mean&Mean&Mean`, 1)
#test eigen with supplied marginality for tier 2 only
plot.marg <- array.plot.trt.canon$marginality$plot
apt.tier2.canon <- designAnatomy(formulae = list(array = ~ (Set:Array)*Dye,
plot = ~ Block/Plant/Sample,
trt = ~ Treat),
marginality = list(plot = plot.marg), orthog = "eigen",
labels = "sources", data = jr.lay)
summary(apt.tier2.canon)
testthat::expect_true(all(apt.tier2.canon$sources$array ==
c("Set:Array", "Dye", "Set:Array:Dye")))
testthat::expect_true(all(apt.tier2.canon$sources$plot ==
c("Block", "Plant[Block]", "Sample[Block:Plant]")))
testthat::expect_equal(length(apt.tier2.canon$marginality), 3)
testthat::expect_equal(nrow(apt.tier2.canon$marginality$plot), 3)
apt.tier2.gm.canon <- designAnatomy(formulae = list(array = ~ (Set:Array)*Dye,
plot = ~ Block/Plant/Sample,
trt = ~ Treat),
marginality = list(plot = plot.marg), orthog = "eigen",
grandMean = TRUE, labels = "sources", data = jr.lay)
summary(apt.tier2.gm.canon)
testthat::expect_true(all(apt.tier2.gm.canon$sources$array ==
c("Mean", "Set:Array", "Dye", "Set:Array:Dye")))
testthat::expect_true(all(apt.tier2.gm.canon$sources$plot ==
c("Mean", "Block", "Plant[Block]", "Sample[Block:Plant]")))
testthat::expect_equal(length(apt.tier2.gm.canon$marginality), 3)
testthat::expect_equal(nrow(apt.tier2.gm.canon$marginality$plot), 3)
testthat::expect_equal(apt.tier2.gm.canon$Q[[3]]$`Mean&Mean&Mean`, 1)
})
cat("#### Test for Baby pseudoterm example\n")
test_that("Baby", {
skip_on_cran()
library(dae)
#'## Baby pseudoterm example
pseudo.lay <- data.frame(pl = factor(1:12),
ab = factor(rep(1:4, times=3)),
a = factor(rep(1:2, times=6)))
pseudo.canon <- designAnatomy(formulae = list(unit=~pl, trt=~a+ab),
labels = "sources", data = pseudo.lay)
summary(pseudo.canon)
testthat::expect_equal(pseudo.canon$Q[[2]]$'pl&ab[a]', 2)
pseudo.canon <- designAnatomy(formulae = list(unit=~pl, trt=~ab+a),
labels = "sources", data = pseudo.lay)
summ.hybrid <- summary(pseudo.canon)
testthat::expect_equal(nrow(summ.hybrid$aliasing), 2)
testthat::expect_equal(ncol(summ.hybrid$aliasing), 7)
testthat::expect_equal(pseudo.canon$Q[[2]]$'pl&ab', 3)
testthat::expect_equal(pseudo.canon$Q[[2]]$'pl&Residual', 8)
pseudo.canon <- designAnatomy(formulae = list(unit=~pl, trt=~ab+a),
orthogonalize = "diff",
labels = "sources", data = pseudo.lay)
summ.diff <- summary(pseudo.canon)
testthat::expect_equal(nrow(summ.diff$aliasing), 2)
testthat::expect_equal(ncol(summ.diff$aliasing), 7)
testthat::expect_equal(pseudo.canon$Q[[2]]$'pl&ab', 3)
testthat::expect_equal(pseudo.canon$Q[[2]]$'pl&Residual', 8)
pseudo.canon <- designAnatomy(formulae = list(unit=~pl, trt=~ab+a),
orthogonalize = "eigen",
labels = "sources", data = pseudo.lay)
summ.eigen <- summary(pseudo.canon)
testthat::expect_equal(nrow(summ.eigen$aliasing), 1)
testthat::expect_equal(ncol(summ.eigen$aliasing), 7)
testthat::expect_equal(pseudo.canon$Q[[2]]$'pl&ab', 3)
testthat::expect_equal(pseudo.canon$Q[[2]]$'pl&Residual', 8)
})
cat("#### Test for pseudoreplicated N experiment\n")
test_that("pseudoN", {
skip_on_cran()
library(dae)
#'## A design with the same RCBD in each Area
sameRCBD.lay <- designRandomize(allocated = fac.gen(list(Nitrogen = 3, 3, Varieties = 24)),
recipient = list(Areas = 3, Blocks = 3, Plots = 24),
nested.recipients = list(Plots = "Blocks"),
seed = 6411)
sameRCBD.lay <- within(sameRCBD.lay,
{
Plot <- fac.combine(list(Blocks,Plots))
})
testthat::expect_equal(nrow(sameRCBD.lay), 216)
testthat::expect_equal(ncol(sameRCBD.lay), 6)
#'### nested numbering of levels
sameRCBD.canon <- designAnatomy(formulae = list(unit = ~ Areas*(Blocks/Plots),
trt = ~ Nitrogen*Varieties),
data = sameRCBD.lay,
labels = "sources", grandMean = TRUE)
testthat::expect_true(all(unlist(sameRCBD.canon$Q[[2]]) == c(1,2,2,23,46,4,46,92)))
testthat::expect_equal(names(sameRCBD.canon$Q[[1]][4]), "Plots[Blocks]")
#Test for use of label.swap
summ.s <- summary(sameRCBD.canon, which = c('aeff','order'))
testthat::expect_equal(summ.s$decomp$Source.unit[4], "Plots[Blocks]")
summ.t <- summary(sameRCBD.canon, which = c('aeff','order'), labels.swap = TRUE)
testthat::expect_equal(summ.t$decomp$Term.unit[4], "Blocks:Plots")
testthat::expect_equal(names(sameRCBD.canon$Q[[1]][4]), "Plots[Blocks]")
#'### unique numbering of levels
sameRCBD.canon <- designAnatomy(formulae = list(unit = ~ Areas*(Blocks + Plot),
trt = ~ Nitrogen*Varieties),
labels = "sources", data = sameRCBD.lay)
summary(sameRCBD.canon, which = c('aeff','order'))
testthat::expect_true(all(unlist(sameRCBD.canon$Q[[2]]) == c(2,2,23,46,4,46,92)))
#'## A design with different RCBDs in each Area
diffRCBD.lay <- designRandomize(allocated = fac.gen(list(Nitrogen = 3, 3, Varieties = 24)),
recipient = list(Areas = 3, Blocks = 3, Plots = 24),
nested.recipients = list(Plots = "Blocks"),
seed = 6467)
diffRCBD.lay <- within(diffRCBD.lay,
{
Block <- fac.combine(list(Areas,Blocks))
Plot <- fac.combine(list(Areas,Blocks,Plots))
})
testthat::expect_equal(nrow(diffRCBD.lay), 216)
testthat::expect_equal(ncol(diffRCBD.lay), 7)
#'### nested numbering of levels
diffRCBD.canon <- designAnatomy(formulae = list(unit = ~ Areas/Blocks/Plots,
trt = ~ Nitrogen*Varieties),
data = diffRCBD.lay,
labels = "sources", grandMean = TRUE)
summary(diffRCBD.canon, which = c('aeff','order'))
testthat::expect_true(all(unlist(diffRCBD.canon$Q[[2]]) == c(1,2,6,23,46,138)))
#'### unique numbering of levels
diffRCBD.canon <- designAnatomy(formulae = list(unit = ~ Areas + Block + Plot,
trt = ~ Nitrogen*Varieties),
labels = "sources", data = diffRCBD.lay)
summary(diffRCBD.canon, which = c('aeff','order'))
testthat::expect_true(all(unlist(diffRCBD.canon$Q[[2]]) == c(2,6,23,46,138)))
#'### Use eigen and diff instead of hybrid
diffRCBD.canon <- designAnatomy(formulae = list(unit = ~ Areas + Block + Plot,
trt = ~ Nitrogen*Varieties),
data = diffRCBD.lay,
labels = "sources", grandMean = TRUE,
orthogonalize = c("eigen", "diff"))
summary(diffRCBD.canon, which = c('aeff','order'))
testthat::expect_true(all(unlist(diffRCBD.canon$Q[[2]]) == c(1,2,6,23,46,138)))
})
cat("#### Test for Repeated LSD for Housewives example\n")
test_that("Housewives", {
skip_on_cran()
library(dae)
data("LSRepeatHwife.dat")
Hwife.struct <- pstructure( ~ Month:Week + Month:Hwife +
Month:Week:Hwife,
labels = "sources", data = LSRepeatHwife.dat)
testthat::expect_equal(nrow(Hwife.struct$aliasing), 2)
testthat::expect_equal(ncol(Hwife.struct$aliasing), 10)
Hwife.canon <- designAnatomy(formulae = list(units = ~ Month:Week + Month:Hwife +
Month:Week:Hwife),
labels = "sources", data = LSRepeatHwife.dat)
summ <- summary(Hwife.canon)
testthat::expect_equal(nrow(summ$aliasing), 2)
testthat::expect_equal(ncol(summ$aliasing), 7)
testthat::expect_equal(nrow(Hwife.canon$aliasing), 2)
testthat::expect_equal(ncol(Hwife.canon$aliasing), 11)
testthat::expect_equal(Hwife.canon$Q[[1]]$`Month:Week`, 7)
testthat::expect_equal(Hwife.canon$Q[[1]]$`Month:Hwife`, 6)
testthat::expect_equal(Hwife.canon$Q[[1]]$`Week#Hwife[Month]`, 18)
testthat::expect_error(Hwife.diff.canon <- designAnatomy(formulae = list(units = ~ Month:Week + Month:Hwife +
Month:Week:Hwife),
labels = "sources",
orthogonalize = "diff", data = LSRepeatHwife.dat))
})
cat("#### Test for Preece examples\n")
test_that("Preece", {
skip_on_cran()
library(dae)
#'## Preece examples with two sets of treatments in a BIBD
#'### two tiers
preece1.lay <- fac.gen(list(block=10, plot=3))
preece1.lay$T1 <- factor(c(1,3,4, 2,4,5, 3,5,1, 4,1,2, 5,2,3,
1,2,5, 2,3,1, 3,4,2, 4,5,3, 5,1,4))
preece1.lay$T2 <- factor(c(1,2,5, 2,3,1, 3,4,2, 4,5,3, 5,1,4,
1,4,3, 2,5,4, 3,1,5, 4,2,1, 5,3,2))
preece1.lay$T3 <- factor(c(1,4,3, 2,5,4, 3,1,5, 4,2,1, 5,3,2,
1,5,2, 2,1,3, 3,2,4, 4,3,5, 5,4,1))
preece1.canon <- designAnatomy(formulae = list(plot= ~ block/plot, trt= ~ T1+T2),
labels = "sources", data = preece1.lay)
summary(preece1.canon, which.criteria = c("aeff", "order"))
testthat::expect_equal(length(preece1.canon$Q[[1]]), 2)
testthat::expect_equal(length(preece1.canon$Q[[1]]$block), 3)
testthat::expect_equal(length(preece1.canon$Q[[1]]$`plot[block]`), 3)
testthat::expect_lt(abs(preece1.canon$Q[[1]]$block$T1$adjusted$aefficiency - 0.1666667), 1e-05)
testthat::expect_lt(abs(preece1.canon$Q[[1]]$block$T2$adjusted$aefficiency - 0.0952), 1e-04)
testthat::expect_lt(abs(preece1.canon$Q[[1]]$`plot[block]`$T1$adjusted$aefficiency - 0.8333333), 1e-05)
testthat::expect_lt(abs(preece1.canon$Q[[1]]$`plot[block]`$T2$adjusted$aefficiency - 0.7619), 1e-04)
testthat::expect_equal(preece1.canon$Q[[2]]$'block&T1', 4)
testthat::expect_equal(preece1.canon$Q[[2]]$'block&T2', 4)
testthat::expect_equal(preece1.canon$Q[[2]]$'block&Residual', 1)
testthat::expect_equal(preece1.canon$Q[[2]]$'plot[block]&T1', 4)
testthat::expect_equal(preece1.canon$Q[[2]]$'plot[block]&T2', 4)
testthat::expect_equal(preece1.canon$Q[[2]]$'plot[block]&Residual', 12)
preece2.canon <- designAnatomy(formulae = list(plot= ~ block/plot, trt= ~ T1+T3),
labels = "sources", data = preece1.lay)
summary(preece2.canon)
testthat::expect_equal(length(preece2.canon$Q[[1]]), 2)
testthat::expect_equal(length(preece2.canon$Q[[1]]$block), 2)
testthat::expect_equal(length(preece2.canon$Q[[1]]$`plot[block]`), 3)
testthat::expect_lt(abs(preece2.canon$Q[[1]]$block$T1$adjusted$aefficiency - 0.1666667), 1e-05)
testthat::expect_lt(abs(preece2.canon$Q[[1]]$`plot[block]`$T1$adjusted$aefficiency - 0.8333333), 1e-05)
testthat::expect_lt(abs(preece2.canon$Q[[1]]$`plot[block]`$T3$adjusted$aefficiency - 0.8571), 1e-04)
testthat::expect_equal(preece2.canon$Q[[2]]$'block&T1', 4)
testthat::expect_equal(preece2.canon$Q[[2]]$'block&Residual', 5)
testthat::expect_equal(preece2.canon$Q[[2]]$'plot[block]&T1', 4)
testthat::expect_equal(preece2.canon$Q[[2]]$'plot[block]&T3', 4)
testthat::expect_equal(preece2.canon$Q[[2]]$'plot[block]&Residual', 12)
})
cat("#### Test for Mostafa's green wall experiment in 2014\n")
test_that("Mostafa", {
skip_on_cran()
library(dae)
#Mostafa's green wall experiment in 2014
data(gwall.lay)
options(width = 100, nwarnings = 150)
set.daeTolerance(1e-06, 1e-06)
pot.treat.canon <- designAnatomy(formulae = list(pot = ~ Rows*Cols,
trt = ~ Species*Irrigation*Media +
First/(SpeCarry*IrrCarry*MedCarry)),
labels = "sources", data = gwall.lay,
keep.order=TRUE)
summary(pot.treat.canon)
testthat::expect_equal(length(pot.treat.canon$Q[[2]]), 17)
testthat::expect_equal(pot.treat.canon$Q[[2]]$`Rows#Cols&Residual`, 69)
testthat::expect_lt(abs(pot.treat.canon$Q[[1]]$`Rows#Cols`$`Species#Irrigation#Media`$adjusted$aefficiency - 0.8240828), 1e-05)
testthat::expect_lt(abs(pot.treat.canon$Q[[1]]$`Rows#Cols`$`SpeCarry#IrrCarry[First]`$adjusted$aefficiency - 0.8320062), 1e-05)
trt.struct <- pstructure(formula = ~ Species*Irrigation*Media +
First/(SpeCarry*IrrCarry*MedCarry),
labels = "sources", data = gwall.lay)
testthat::expect_true(all(names(trt.struct$Q) == c("Species","Irrigation","Species#Irrigation",
"Media","Species#Media","Irrigation#Media",
"Species#Irrigation#Media","First",
"SpeCarry[First]","IrrCarry[First]",
"SpeCarry#IrrCarry[First]")))
#use designAnatomy to call pstructure
trt.canon <- designAnatomy(list(trt = ~ Species*Irrigation*Media +
First/(SpeCarry*IrrCarry*MedCarry)),
labels = "sources", data = gwall.lay)
testthat::expect_true(all(names(trt.canon$Q) == c("Species","Irrigation","Species#Irrigation",
"Media","Species#Media","Irrigation#Media",
"Species#Irrigation#Media","First",
"SpeCarry[First]","IrrCarry[First]",
"SpeCarry#IrrCarry[First]")))
})
cat("#### Test for four-tiered corn example\n")
test_that("corn", {
skip_on_cran()
library(dae)
#'## Four-tiered corn experiment with 3 structures including pseudoterms
#'### Randomize field factors to lab factors
corn1.recip <- list(Intervals=18, ConPlate=36)
corn1.nest <- list(ConPlate = "Intervals")
corn1.alloc <- fac.gen(list(Sites=3, Blocks=2, Plots=3, Lots=36))
#corn1.alloc$Harvesters <- factor(1:3, each=36, times=6)
corn1.lay <- designRandomize(allocated = corn1.alloc,
recipient = corn1.recip,
nested.recipients = corn1.nest,
seed = 81505)
#'### Randomize treatments to lab factors
corn2.recip <- list(Intervals=18, Containers=9, Plates=4)
corn2.nest <- list(Containers = "Intervals", Plates = c("Containers", "Intervals"))
Treats <- factor(rep(1:9, each=4, times=18))
corn2.lay <- designRandomize(allocated = Treats,
recipient = corn2.recip,
nested.recipients = corn2.nest,
seed = 543205)
corn2.lay <- corn2.lay[-1]
#'### Randomize Harvesters to field factors
corn3.recip <- list(Sites=3, Blocks=2, Plots=3, Lots=36)
corn3.nest <- list(Blocks = "Sites", Plots = c("Blocks", "Sites"), Lots = c("Plots", "Blocks", "Sites"))
Harvesters <- factor(rep(1:3, each=36, times=6))
corn3.lay <- designRandomize(allocated = Harvesters,
recipient = corn3.recip,
nested.recipients = corn3.nest,
seed = 135205)
#'### Combine randomizations
corn.lay <- cbind(corn1.lay, corn2.lay)
corn.lay <- merge(corn.lay, corn3.lay)
corn.lay <- corn.lay[c("Intervals", "Containers", "Plates", "ConPlate",
"Sites", "Blocks", "Plots", "Lots",
"Treats", "Harvesters")]
corn.lay <- corn.lay[do.call(order, corn.lay), ]
rownames(corn.lay) <- NULL
#'### Make factors with unique levels
corn.lay <- within(corn.lay,
{
AContainers <- fac.combine(list(Intervals, Containers))
APlates <- fac.combine(list(AContainers, Plates))
ABlocks <- fac.combine(list(Sites, Blocks))
APlots <- fac.combine(list(ABlocks, Plots))
ALots <- fac.combine(list(APlots, Lots))
})
#'## Check properties
corn.canon <- designAnatomy(formulae = list(plate= ~ Intervals + AContainers + APlates,
field= ~ Sites + ABlocks + APlots + ALots,
trts= ~ Sites*Harvesters*Treats),
labels = "sources", data = corn.lay)
summary(corn.canon, which.criteria="aeff")
testthat::expect_equal(corn.canon$Q[[3]]$`Intervals&APlots[Sites:ABlocks]&Residual`, 6)
testthat::expect_equal(corn.canon$Q[[3]]$`AContainers[Intervals]&ALots[Sites:ABlocks:APlots]&Residual`,
72)
testthat::expect_equal(corn.canon$Q[[3]]$`APlates[Intervals:AContainers]&ALots[Sites:ABlocks:APlots]`,
486)
#Create an example with double Residual
corn2Res.canon <- designAnatomy(formulae = list(plate= ~ AContainers + APlates,
field= ~ Sites + ABlocks + ALots,
fldtrts= ~ Harvesters,
labtrts= ~ Treats),
labels = "sources", data = corn.lay)
summary(corn2Res.canon, which.criteria="none")
testthat::expect_equal(corn2Res.canon$Q[[4]]$`AContainers&ALots[Sites:ABlocks]&Residual&Treats`,
8)
testthat::expect_equal(corn2Res.canon$Q[[4]]$`AContainers&ALots[Sites:ABlocks]&Residual&Residual`,
146)
})
cat("#### Test for Piepho example with pseudoreplication\n")
test_that("Piepho", {
skip_on_cran()
library(dae)
#'## Piepho example with pseudoreplication
data('PiephoLSDRand')
piepho.canon <- designAnatomy(formulae = list(lab= ~ Times/(Locations*Ovens),
field= ~ Block/Plot/Sample,
trt= ~ Harvest*Method),
labels = "sources", data = Piepho_LSD_Rand)
summary(piepho.canon, which.criteria="aeff")
testthat::expect_equal(piepho.canon$Q[[3]]$"Times&Plot[Block]&Harvest", 3)
testthat::expect_equal(piepho.canon$Q[[3]]$"Locations[Times]&Block", 2)
testthat::expect_equal(piepho.canon$Q[[3]]$"Locations[Times]&Plot[Block]", 6)
testthat::expect_equal(piepho.canon$Q[[3]]$"Ovens[Times]&Sample[Block:Plot]", 8)
testthat::expect_equal(piepho.canon$Q[[3]]$"Locations#Ovens[Times]&Sample[Block:Plot]&Method",2)
testthat::expect_equal(piepho.canon$Q[[3]]$"Locations#Ovens[Times]&Sample[Block:Plot]&Harvest#Method", 6)
testthat::expect_equal(piepho.canon$Q[[3]]$"Locations#Ovens[Times]&Sample[Block:Plot]&Residual", 8)
Piepho_LSD_Rand <- within(Piepho_LSD_Rand,
{
ALocations <- fac.combine(list(Times, Locations))
AOvens <- fac.combine(list(Times, Ovens))
APositions <- fac.combine(list(Times, Locations, Ovens))
APlot <- fac.combine(list(Block, Plot))
ASample <- fac.combine(list(Block, Plot, Sample))
})
piephoA.canon <- designAnatomy(formulae = list(lab= ~ Times + ALocations + AOvens + APositions,
field= ~ Block + APlot + ASample,
trt= ~ Harvest*Method),
labels = "sources", data = Piepho_LSD_Rand)
summary(piephoA.canon, which.criteria="aeff")
testthat::expect_equal(piephoA.canon$Q[[3]]$"Times&APlot[Block]&Harvest", 3)
testthat::expect_equal(piephoA.canon$Q[[3]]$"ALocations[Times]&Block", 2)
testthat::expect_equal(piephoA.canon$Q[[3]]$"ALocations[Times]&APlot[Block", 6)
testthat::expect_equal(piephoA.canon$Q[[3]]$"AOvens[Times]&ASample[Block:APlot]", 8)
testthat::expect_equal(piephoA.canon$Q[[3]]$"APositions[Times]&ASample[Block:APlot]&Method",2)
testthat::expect_equal(piephoA.canon$Q[[3]]$"APositions[Times]&ASample[Block:APlot]&Harvest#Method", 6)
testthat::expect_equal(piephoA.canon$Q[[3]]$"APositions[Times]&ASample[Block:APlot]&Residual", 8)
})
cat("#### FAME example with complicated pseudoterm structure\n")
test_that("FAME", {
skip_on_cran()
library(dae)
"FAME example with complicated pseudoterm structure"
data('FAME')
FAME[c("Int1","Int2","Int3","Int4","Int5","Int6")] <-
lapply(FAME[c("Int1","Int2","Int3","Int4","Int5","Int6")], factor)
fame.canon <- designAnatomy(formulae = list(lab= ~ Int1:Int2:Int3/Int4/Int5/Int6,
field= ~ ((Block/Plot)*Depth)/Sample,
trt= ~ Tillage*Depth*Method),
labels = "sources", data = FAME)
summary(fame.canon, which.criteria="aeff")
testthat::expect_equal(length(fame.canon$Q[[2]]), 14)
testthat::expect_equal(length(fame.canon$Q[[3]]), 20)
testthat::expect_equal(fame.canon$Q[[3]]$'Int1:Int2:Int3&Sample[Block:Plot:Depth]&Residual', 1)
testthat::expect_equal(fame.canon$Q[[3]]$'Int5[Int1:Int2:Int3:Int4]&Plot[Block]&Residual', 3)
testthat::expect_equal(fame.canon$Q[[3]]$'Int5[Int1:Int2:Int3:Int4]&Sample[Block:Plot:Depth]&Residual', 3)
testthat::expect_equal(fame.canon$Q[[3]]$'Int6[Int1:Int2:Int3:Int4:Int5]&Plot#Depth[Block]&Residual', 3)
testthat::expect_equal(fame.canon$Q[[3]]$'Int6[Int1:Int2:Int3:Int4:Int5]&Sample[Block:Plot:Depth]&Residual', 6)
#Form factors with unique levels
FAME <- within(FAME,
{
Int2 <- fac.combine(list(Int1,Int2))
Int3 <- fac.combine(list(Int2,Int3))
Int4 <- fac.combine(list(Int3,Int4))
Int5 <- fac.combine(list(Int4,Int5))
Int6 <- fac.combine(list(Int5,Int6))
Plot <- fac.combine(list(Block,Plot))
Sample <- fac.combine(list(Plot,Depth,Sample))
})
fameA.canon <- designAnatomy(formulae = list(lab= ~ Int3 + Int4 + Int5 + Int6,
field= ~ (Block + Plot)*Depth + Sample,
trt= ~ Tillage*Depth*Method),
labels = "sources", data = FAME)
summary(fameA.canon, which.criteria="aeff")
testthat::expect_equal(length(fameA.canon$Q[[2]]), 14)
testthat::expect_equal(length(fameA.canon$Q[[3]]), 20)
testthat::expect_equal(fameA.canon$Q[[3]]$'Int3&Sample[Block:Plot:Depth]&Residual', 1)
testthat::expect_equal(fameA.canon$Q[[3]]$'Int5[Int3:Int4]&Plot[Block]&Residual', 3)
testthat::expect_equal(fameA.canon$Q[[3]]$'Int5[Int3:Int4]&Sample[Block:Plot:Depth]&Residual', 3)
testthat::expect_equal(fameA.canon$Q[[3]]$'Int6[Int3:Int4:Int5]&Plot#Depth[Block]&Residual', 3)
testthat::expect_equal(fameA.canon$Q[[3]]$'Int6[Int3:Int4:Int5]&Sample[Block:Plot:Depth]&Residual', 6)
})
cat("#### Test for Piracicaba Euc pulp example\n")
test_that("EucPulp", {
skip_on_cran()
library(dae)
"Piracicaba Euc pulp example- an example with no Residuals"
data('EucPulp2x2')
euc.canon <- designAnatomy(formulae = list(lab= ~ Runs/Positions,
cook= ~ Cookings/Samples,
trt= ~ ((Kinds*Ages)/Lots/Batches)*Times),
labels = "sources", data = Euc_Pulp2x2)
summary(euc.canon, which.criteria="aeff")
testthat::expect_equal(length(euc.canon$Q[[3]]), 11)
testthat::expect_equal(euc.canon$Q[[3]]$'Runs&Cookings&Batches[Kinds:Ages:Lots]', 36)
testthat::expect_equal(euc.canon$Q[[3]]$'Positions[Runs]&Samples[Cookings]&Batches#Times[Kinds:Ages:Lots]', 180)
})
cat("#### Test for Split plot with rows and columns in main and split-plots\n")
test_that("SpliPlotRowsColumns", {
skip_on_cran()
library(dae)
#'## Split plot with rows and columns in main and split-plots
data('LS4.CC4x4.1a')
split.recip <- LS4_CC4x4_1a[, 1:4]
split.nest <- list(SubCols = "BigRows")
split.trt <- LS4_CC4x4_1a[, 5:8]
split.layout <- designRandomize(allocated = split.trt,
recipient = split.recip,
nested.recipients = split.nest,
seed = 7154)
#'### Check design
split.canon <- designAnatomy(formulae = list(plot= ~ ((BigRows/SubCols)*BigCols)*SubRows,
trts= ~ Soils*Varieties*TreatB*MF),
labels = "sources", data = split.layout)
summary(split.canon, which.criteria=c("aeff","ord"))
testthat::expect_equal(length(split.canon$Q[[1]]), 11)
testthat::expect_equal(split.canon$Q[[1]]$'SubCols[BigRows]'$'Soils#TreatB#MF'$adjusted$aefficiency, 0.25)
testthat::expect_equal(split.canon$Q[[1]]$'SubCols#BigCols[BigRows]'$'Soils#TreatB#MF'$adjusted$aefficiency, 0.75)
testthat::expect_equal(split.canon$Q[[1]]$'SubCols#SubRows[BigRows]'$'Soils#Varieties#TreatB#MF'$adjusted$aefficiency, 0.25)
testthat::expect_equal(split.canon$Q[[1]]$'SubCols#BigCols#SubRows[BigRows]'$'Soils#Varieties#TreatB#MF'$adjusted$aefficiency, 0.75)
testthat::expect_equal(split.canon$Q[[2]]$'SubCols#BigCols#SubRows[BigRows]&Residual', 72)
Q.plot <- pstructure( ~ ((BigRows/SubCols)*BigCols)*SubRows,
labels = "sources", data = split.layout)
names (Q.plot)
split.layout <- within(split.layout,
{
ASubCols <- fac.combine(list(BigRows, SubCols))
})
splitA.canon <- designAnatomy(formulae = list(plot= ~ ((BigRows + ASubCols)*BigCols)*SubRows,
trts= ~ Soils*Varieties*TreatB*MF),
labels = "sources", data = split.layout)
summary(splitA.canon, which.criteria=c("aeff","ord"))
testthat::expect_equal(length(splitA.canon$Q[[1]]), 11)
testthat::expect_equal(splitA.canon$Q[[1]]$'ASubCols[BigRows]'$'Soils#TreatB#MF'$adjusted$aefficiency, 0.25)
testthat::expect_equal(splitA.canon$Q[[1]]$'ASubCols#BigCols[BigRows]'$'Soils#TreatB#MF'$adjusted$aefficiency, 0.75)
testthat::expect_equal(splitA.canon$Q[[1]]$'ASubCols#SubRows[BigRows]'$'Soils#Varieties#TreatB#MF'$adjusted$aefficiency, 0.25)
testthat::expect_equal(splitA.canon$Q[[1]]$'ASubCols#BigCols#SubRows[BigRows]'$'Soils#Varieties#TreatB#MF'$adjusted$aefficiency, 0.75)
testthat::expect_equal(splitA.canon$Q[[2]]$'ASubCols#BigCols#SubRows[BigRows]&Residual', 72)
})
cat("#### Test for EXP249 - a two-phae, p-rep design\n")
test_that("Exp249", {
skip_on_cran()
library(dae)
data(file="Exp249.mplot.sys")
Exp249.mplot.sys$Blocks <- factor(rep(1:6, each = 44))
#'## Expand design to rerandomize lines and to assign conditions to locations
Exp249.recip <- list(Groups = 6, Columns = 4, Pairs = 11, Locations = 2)
Exp249.nest <- list(Columns = c("Groups", "Pairs"),
Locations = c("Groups", "Columns", "Pairs"))
Exp249.alloc <- data.frame(Lines = factor(rep(Exp249.mplot.sys$Lines, each=2),
levels=1:75),
Checks = fac.recode(rep(Exp249.mplot.sys$Lines, each=2),
newlevels=c(rep(3, 73), 1 , 2),
labels = c("NAM","Scout","Gladius")),
Conditions = factor(rep(1:2, times=264),
labels = c('0 NaCl','100 NaCl')))
Exp249.lay <- designRandomize(allocated = Exp249.alloc,
recipient = Exp249.recip,
nested.recipients = Exp249.nest,
seed = 51412)
#'## Add second-phase factors
#'## (to which the first-phase factors have been systematically allocated)
Exp249.lay <- cbind(fac.gen(list(Lanes = 24, Positions = 2:23)),
fac.gen(list(Zones = 6, Rows = 4, MainPosn = 11, Subplots = 2)),
Exp249.lay)
#'## Check design properties
Exp249.canon <- designAnatomy(formulae = list(carts = ~(Zones*MainPosn)/Rows/Subplots,
tables = ~(Groups*Pairs)/Columns/Locations,
treats = ~(Checks + Lines) * Conditions),
labels = "sources", data = Exp249.lay)
summary(Exp249.canon)
testthat::expect_equal(length(Exp249.canon$Q[[1]]), 5)
testthat::expect_lt(abs(Exp249.canon$Q[[2]]$'Zones&Groups'$'Lines'$adjusted$aefficiency - 0.1498311), 1e-05)
testthat::expect_lt(abs(Exp249.canon$Q[[2]]$'Rows[Zones:MainPosn]&Columns[Groups:Pairs]'$'Lines'$adjusted$aefficiency - 0.6639769), 1e-05)
testthat::expect_lt(abs(Exp249.canon$Q[[2]]$'Subplots[Zones:MainPosn:Rows]&Locations[Groups:Pairs:Columns]'$'Conditions'$adjusted$aefficiency - 1), 1e-05)
testthat::expect_equal(Exp249.canon$Q[[3]]$'Rows[Zones:MainPosn]&Columns[Groups:Pairs]&Residual', 124)
testthat::expect_equal(Exp249.canon$Q[[3]]$'Subplots[Zones:MainPosn:Rows]&Locations[Groups:Pairs:Columns]&Residual', 189)
#'## Add factors and variates for new analysis
Exp249.lay <- within(Exp249.lay,
{ xMainPosn <- as.numfac(MainPosn)
xMainPosn <- -(xMainPosn - mean(xMainPosn))
Mainplots <- fac.combine(list(Rows,MainPosn))
})
#'## Check properties if only linear trend fitted
Exp249.canon <- designAnatomy(formulae = list(cart = ~Zones/Mainplots/Subplots,
treat = ~xMainPosn + (Checks + Lines) * Conditions),
data = Exp249.lay,
labels = "sources", orthogonalize = c("diff", "eigenmethods"))
summ <- summary(Exp249.canon)
testthat::expect_equal(nrow(summ$aliasing), 2)
testthat::expect_equal(ncol(summ$aliasing), 7)
testthat::expect_equal(length(Exp249.canon$Q[[1]]), 3)
testthat::expect_lt(abs(Exp249.canon$Q[[1]]$'Zones'$'Lines'$adjusted$aefficiency - 0.1499827), 1e-05)
testthat::expect_lt(abs(Exp249.canon$Q[[1]]$'Mainplots[Zones]'$'Lines'$adjusted$aefficiency - 0.987877), 1e-05)
testthat::expect_lt(abs(Exp249.canon$Q[[1]]$'Subplots[Zones:Mainplots]'$'Conditions'$adjusted$aefficiency - 1), 1e-05)
testthat::expect_equal(Exp249.canon$Q[[2]]$'Mainplots[Zones]&Residual', 183)
testthat::expect_equal(Exp249.canon$Q[[2]]$'Subplots[Zones:Mainplots]&Residual', 189)
Exp249.lay <- within(Exp249.lay,
{
AMainplots <- fac.combine(list(Zones, Mainplots))
ASubplots <- fac.combine(list(AMainplots,Subplots))
})
Exp249A.canon <- designAnatomy(formulae = list(cart = ~Zones + AMainplots + ASubplots,
treat = ~xMainPosn + (Checks + Lines) * Conditions),
labels = "sources", data = Exp249.lay)
summary(Exp249A.canon)
testthat::expect_equal(length(Exp249.canon$Q[[1]]), 3)
testthat::expect_lt(abs(Exp249A.canon$Q[[1]]$'Zones'$'Lines[Checks]'$adjusted$aefficiency - 0.1499827), 1e-05)
testthat::expect_lt(abs(Exp249A.canon$Q[[1]]$'AMainplots[Zones]'$'Lines[Checks]'$adjusted$aefficiency - 0.987877), 1e-05)
testthat::expect_lt(abs(Exp249A.canon$Q[[1]]$'ASubplots[Zones:AMainplots]'$'Conditions'$adjusted$aefficiency - 1), 1e-05)
testthat::expect_equal(Exp249A.canon$Q[[2]]$'AMainplots[Zones]&Residual', 183)
testthat::expect_equal(Exp249A.canon$Q[[2]]$'ASubplots[Zones:AMainplots]&Residual', 189)
})
cat("#### Test for Brien and Payne 3-tier sensory experiment\n")
test_that("Sensory3tier", {
skip_on_cran()
library(dae)
#Three-tier sensory experiment
data("Need3.dat")
#Do short names version
names(Need3.dat)[match(c("Occasions", "Intervals", "Sittings", "Positions", "Judges",
"Squares", "Rows", "Columns", "Halfplots"), names(Need3.dat))] <-
c("Occ", "Int", "Sit", "Pos", "Jud", "Sqr", "Row", "Col", "HPlot")
#'## Complete decomposition
Eval.Field.Treat.canon <- designAnatomy(list(eval=~ ((Occ/Int/Sit)*Jud)/Pos,
field=~ (Row*(Sqr/Col))/HPlot,
treats=~ Trellis*Method),
labels = "sources", data=Need3.dat)
summary(Eval.Field.Treat.canon, which.criteria =c("aefficiency", "order"))
testthat::expect_equal(names(Eval.Field.Treat.canon$Q[[1]]),
c("Occ","Int[Occ]","Sit[Occ:Int]","Jud","Occ#Jud","Int#Jud[Occ]",
"Sit#Jud[Occ:Int]","Pos[Occ:Int:Sit:Jud]"))
testthat::expect_equal(names(Eval.Field.Treat.canon$Q[[2]]),
c("Occ&Sqr","Int[Occ]","Sit[Occ:Int]&Col[Sqr]","Sit[Occ:Int]&Residual",
"Jud","Occ#Jud","Int#Jud[Occ]&Row","Int#Jud[Occ]&Row#Sqr",
"Int#Jud[Occ]&Residual","Sit#Jud[Occ:Int]&Col[Sqr]",
"Sit#Jud[Occ:Int]&Row#Col[Sqr]","Sit#Jud[Occ:Int]&Residual",
"Pos[Occ:Int:Sit:Jud]&HPlot[Row:Sqr:Col]",
"Pos[Occ:Int:Sit:Jud]&Residual"))
testthat::expect_equal(names(Eval.Field.Treat.canon$Q[[3]]),
c("Occ&Sqr","Int[Occ]","Sit[Occ:Int]&Col[Sqr]&Trellis",
"Sit[Occ:Int]&Col[Sqr]&Residual","Sit[Occ:Int]&Residual",
"Jud","Occ#Jud","Int#Jud[Occ]&Row","Int#Jud[Occ]&Row#Sqr",
"Int#Jud[Occ]&Residual","Sit#Jud[Occ:Int]&Col[Sqr]&Trellis",
"Sit#Jud[Occ:Int]&Col[Sqr]&Residual","Sit#Jud[Occ:Int]&Row#Col[Sqr]&Trellis",
"Sit#Jud[Occ:Int]&Row#Col[Sqr]&Residual","Sit#Jud[Occ:Int]&Residual",
"Pos[Occ:Int:Sit:Jud]&HPlot[Row:Sqr:Col]&Method",
"Pos[Occ:Int:Sit:Jud]&HPlot[Row:Sqr:Col]&Trellis#Method",
"Pos[Occ:Int:Sit:Jud]&HPlot[Row:Sqr:Col]&Residual",
"Pos[Occ:Int:Sit:Jud]&Residual"))
testthat::expect_equal(Eval.Field.Treat.canon$Q[[3]]$'Sit#Jud[Occ:Int]&Col[Sqr]&Trellis', 3)
testthat::expect_equal(Eval.Field.Treat.canon$Q[[3]]$'Sit#Jud[Occ:Int]&Col[Sqr]&Residual', 3)
testthat::expect_equal(Eval.Field.Treat.canon$Q[[3]]$'Sit#Jud[Occ:Int]&Row#Col[Sqr]&Trellis', 3)
testthat::expect_equal(Eval.Field.Treat.canon$Q[[3]]$'Sit#Jud[Occ:Int]&Row#Col[Sqr]&Residual', 9)
summ <- summary(Eval.Field.Treat.canon, which.criteria =c("aefficiency", "order"))
testthat::expect_true(all(abs(summ$decomp[11:14,7] -
c(0.07407407,0.66666667,0.88888889,1.00000000)) < 1e-06))
})
Try the dae package in your browser
Any scripts or data that you put into this service are public.
dae documentation built on Aug. 7, 2023, 5:08 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#devtools::test("dae")
context("canonical")
cat("#### Test for source formation\n")
test_that("sources", {
skip_on_cran()
library(dae)
#((A*B)/C)*D
ABCD.lay <- fac.gen(list(A = 3, B = 3, C = 3, D = 3))
ABCD.struct <- pstructure(~ ((A*B)/C)*D, labels = "sources", data =ABCD.lay)
ABCD.dat <- as.data.frame(ABCD.struct)
testthat::expect_equal(names(ABCD.struct$Q), ABCD.dat$sources)
testthat::expect_equal(ABCD.dat$sources,
c("A","B","A#B","C[A:B]","D","A#D","B#D","A#B#D","C#D[A:B]"))
ABCD.struct <- pstructure(~ ((A*B)/C)*D, omit.projectors = TRUE, labels = "terms", data =ABCD.lay)
ABCD.dat <- as.data.frame(ABCD.struct)
testthat::expect_equal(ABCD.dat$df, c(2,2,4,18,2,4,4,8,36))
#Generalized factor crossed with others
genfac1.lay <- fac.gen(list(S = 3, A = 3, D = 3))
gf1.struct <- pstructure(~ (S:A)*D, labels = "sources", data =genfac1.lay)
testthat::expect_equal(unname(gf1.struct$sources), c("S:A","D","(S:A)#D"))
#Generalized factor nested within another factor
gf2.struct <- pstructure(~ D/(S:A), labels = "sources", data =genfac1.lay)
testthat::expect_equal(unname(gf2.struct$sources), c("D","S:A[D]"))
#Generalized factor nesting another factor
gf3.struct <- pstructure(~ (S:A)/D, labels = "sources", data =genfac1.lay)
testthat::expect_equal(unname(gf3.struct$sources), c("S:A","D[S:A]"))
#Two generalized factor nested within another and each other
genfac4.lay <- fac.gen(list(S = 3, A = 3, D = 3, B = 3, C = 3))
gf4.struct <- pstructure(~ D/(S:A)/(B:C), labels = "sources", data =genfac4.lay)
testthat::expect_equal(unname(gf4.struct$sources), c("D","S:A[D]","B:C[D:S:A]"))
#Two generalized factor nested within another and each other - add grand mean
gf4gm.struct <- pstructure(~ D/(S:A)/(B:C), labels = "sources", grandMean = TRUE, data =genfac4.lay)
testthat::expect_equal(unname(gf4gm.struct$sources), c("Mean", "D","S:A[D]","B:C[D:S:A]"))
testthat::expect_equal(nrow(as.data.frame(gf4gm.struct, omit.marginality = TRUE)), 4)
#Single term
one.struct <- pstructure(~ D, labels = "sources", data =genfac4.lay)
#Single term with grand mean
one.struct <- pstructure(~ D, labels = "sources", grandMean = TRUE, data =genfac4.lay)
testthat::expect_equal(unname(one.struct$terms), c("Mean", "D"))
testthat::expect_equal(unname(one.struct$sources), c("Mean", "D"))
testthat::expect_equal(nrow(as.data.frame(one.struct, omit.marginality = TRUE)), 2)
})
cat("#### Test for designAnatomy for Thao designs\n")
test_that("Thao", {
skip_on_cran()
library(dae)
Br <- 4
Bc <- 4
Sr<-4
Sc<-4
n <- Sr*Sc*Br*Bc
v<- 4
s<-4
##### Poset 2f design 2
# Factor D and E are latinised using LCCD.
LS1 <- factor(c(1:4, 4:1, 2,1,4,3,3,4,1,2 ))
LS2 <- factor(c(1:4,2,1,4,3,3,4,1,2,4,3,2,1 ))
LS3 <- factor(c(1:4, 3,4,1,2, 4:1, 2,1,4,3))
LS4 <- factor(c(1:4, 2,1,4,3, 3,4,1,2, 4:1))
LS4.CC4x4.2f.ran <- data.frame(
A = factor(c(rep(c(1,2,1,2 ,2,1,2,1 ,1,2,1,2 ,2,1,2,1), each=16))),
B = factor(c(rep(c(1,1,2,2 ,1,1,2,2 ,2,2,1,1 ,2,2,1,1), each=16))),
D = factor(c(rep(LS1[1:4],each=4), rep(LS1[5:8],each=4),rep(LS1[9:12],each=4),rep(LS1[13:16],each=4)
,rep(LS2[1:4],each=4), rep(LS2[5:8],each=4),rep(LS2[9:12],each=4),rep(LS2[13:16],each=4)
,rep(LS3[1:4],each=4), rep(LS3[5:8],each=4),rep(LS3[9:12],each=4),rep(LS3[13:16],each=4)
,rep(LS4[1:4],each=4), rep(LS4[5:8],each=4),rep(LS4[9:12],each=4),rep(LS4[13:16],each=4))),
E = factor(c(rep(LS1[1:4],times=4),rep(LS2[1:4],times=4),rep(LS3[1:4],times=4),rep(LS4[1:4],times=4)
,rep(LS1[5:8],times=4), rep(LS2[5:8],times=4), rep(LS3[5:8],times=4),rep(LS4[5:8],times=4)
,rep(LS1[9:12],times=4),rep(LS2[9:12],times=4),rep(LS3[9:12],times=4),rep(LS4[9:12],times=4)
,rep(LS1[13:16],times=4),rep(LS2[13:16],times=4),rep(LS3[13:16],times=4) ,rep(LS4[13:16],times=4))))
#generate layout
LS4.CC4x4.2f.lay <- designRandomize(allocated=LS4.CC4x4.2f.ran,
recipient = list(BigRows= Br, BigColumns=Bc, Rows=Sr, Columns=Sc),
nested.recipients = list(Columns="BigColumns", Rows="BigRows"),
seed = 550)
#Compute anatomy
LS4.CC4x4.2f.canon <- designAnatomy(list(unit = ~ (BigRows/Rows)*(BigColumns/Columns),
trt = ~ A*B*D*E),
data = LS4.CC4x4.2f.lay)
testthat::expect_true(all(LS4.CC4x4.2f.canon$sources$unit ==
c("BigRows", "Rows[BigRows]", "BigColumns", "Columns[BigColumns]",
"BigRows#BigColumns", "BigRows#Columns[BigColumns]",
"Rows#BigColumns[BigRows]", "Rows#Columns[BigRows:BigColumns]")))
summary(LS4.CC4x4.2f.canon, which.criteria = c("aeff", "xeff", "eeff", "order"))
#### Poset 3c, design 1 - an N-poset
#Set up allocated factors
LS4.CC4x4.3c.ran <- cbind(data.frame(A = factor(rep(c(1,1,2,2 ,1,1,2,2 ,2,2,1,1 ,2,2,1,1), each = 16)),
B = factor(rep(c(1,2,1,2 ,2,1,2,1 ,1,2,1,2 ,2,1,2,1), each = 16))),
fac.gen(list(D = 4, E = 4), times = 16))
#generate layout and analyze
LS4.CC4x4.3c.lay <- designRandomize(allocated=LS4.CC4x4.3c.ran,
recipient = list(BigRows= Br, BigColumns=Bc, Rows=Sr, Columns=Sc),
nested.recipients = list(Rows="BigRows", Columns=c("BigRows","BigColumns")),
seed = 550)
#Compute anatomy
LS4.CC4x4.3c.canon <- designAnatomy(list(unit = ~ (BigRows/Rows)*BigColumns +((BigColumns*BigRows)/Columns)/Rows,
trt = ~ A*B*D*E),
data =LS4.CC4x4.3c.lay)
testthat::expect_true(all(LS4.CC4x4.3c.canon$sources$unit ==
c("BigRows", "Rows[BigRows]", "BigColumns", "BigRows#BigColumns",
"Rows#BigColumns[BigRows]", "Columns[BigRows:BigColumns]",
"Rows#Columns[BigRows:BigColumns]")))
summary(LS4.CC4x4.3c.canon, which.criteria = c("aeff", "order"))
### Poset 4a
LS4x4.CC5x5.4a.ran <- cbind(data.frame(A = factor(rep(c(1,2,1,2 ,2,1,2,1 ,1,2,1,2 ,2,1,2,1), each = 16)),
B = factor(rep(c(1,1,2,2 ,1,1,2,2 ,2,2,1,1 ,2,2,1,1), each = 16))),
fac.gen(list(D = 4, E = 4), times = 16))
#generate layout and analyze
LS4x4.CC5x5.4a.lay <- designRandomize(allocated=LS4x4.CC5x5.4a.ran,
recipient = list(BigRows= Br, BigColumns=Bc, Rows=Sr, Columns=Sc),
nested.recipients = list(Columns=c("BigRows","BigColumns"),
Rows=c("BigRows","BigColumns")),
seed = 690)
#Compute anatomy
LS4x4.CC5x5.4a.lcanon <- designAnatomy(list(unit = ~ (BigRows*BigColumns)/(Rows*Columns),
trt = ~ A*B*D*E),
data =LS4x4.CC5x5.4a.lay)
testthat::expect_true(all(LS4x4.CC5x5.4a.lcanon$sources$unit ==
c("BigRows", "BigColumns", "BigRows#BigColumns", "Rows[BigRows:BigColumns]",
"Columns[BigRows:BigColumns]", "Rows#Columns[BigRows:BigColumns]")))
summary(LS4x4.CC5x5.4a.lcanon, which.criteria = c("aeff", "order"))
})
cat("#### Test for designAnatomy with sources and marginality using Cochran&Cox PBIBD2\n")
test_that("PBIBD2_sources", {
skip_on_cran()
library(dae)
#'# PBIBD(2) from p. 379 of Cochran and Cox (1957) Experimental Designs. 2nd edn Wiley, New York"
#'## Input the design and randomize"
Treatments <- factor(c(1,4,2,5, 2,5,3,6, 3,6,1,4, 4,1,5,2, 5,2,6,3, 6,3,4,1))
PBIBD2.lay <- designRandomize(allocated = Treatments,
recipient = list(Blocks =6, Units = 4),
nested.recipients = list(Units = "Blocks"),
seed = 98177)
#'## Test that projs.canon has been deprecated
testthat::expect_warning(PBIBD2.canon <-
projs.canon(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
which.criteria = c('aeff', 'xeff', 'eeff','order'),
labels = "sources", data = PBIBD2.lay))
#'##By differencing
PBIBD2D.canon <-
designAnatomy(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
which.criteria = c('aeff', 'xeff', 'eeff','order'),
labels = "sources", orthogonalize = "diff", data = PBIBD2.lay)
summary(PBIBD2D.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_equal(PBIBD2D.canon$Q[[1]]$Blocks$Treatments$adjusted$aefficiency, 0.25)
testthat::expect_lt(abs(PBIBD2D.canon$Q[[1]]$'Units[Blocks]'$Treatments$adjusted$aefficiency - 0.8824), 1e-04)
testthat::expect_equal(PBIBD2D.canon$Q[[2]]$'Blocks&Treatments', 2)
testthat::expect_equal(PBIBD2D.canon$Q[[2]]$'Blocks&Residual', 3)
testthat::expect_equal(PBIBD2D.canon$Q[[2]]$'Units[Blocks]&Treatments', 5)
testthat::expect_equal(PBIBD2D.canon$Q[[2]]$'Units[Blocks]&Residual', 13)
testthat::expect_lt(abs(PBIBD2D.canon$Q[[1]]$'Units[Blocks]'$Treatments$adjusted$aefficiency -
0.8824), 1e-04)
testthat::expect_null(PBIBD2D.canon$aliasing$unit)
testthat::expect_null(PBIBD2D.canon$aliasing$trt)
PBIBD2.marg <- PBIBD2D.canon$marginality
#'##By differencing with grand mean
PBIBD2Dg.canon <-
designAnatomy(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
grandMean = TRUE, labels = "sources", orthogonalize = "diff",
which.criteria = c('aeff', 'xeff', 'eeff','order'),
data = PBIBD2.lay)
summary(PBIBD2Dg.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_equal(PBIBD2Dg.canon$Q[[2]]$`Mean&Mean`, 1)
#'##By eigenmethods
PBIBD2E.canon <-
designAnatomy(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
which.criteria = c('aeff', 'xeff', 'eeff','order'),
labels = "sources", orthogonalize = "eigen", data = PBIBD2.lay)
summary(PBIBD2E.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_true(attr(PBIBD2E.canon, which = "labels") == "terms")
testthat::expect_lt(abs(PBIBD2E.canon$Q[[1]]$'Blocks:Units'$Treatments$adjusted$aefficiency -
0.8824), 1e-04)
#'##By eigenmethods with supplied marginality
PBIBD2Em.canon <-
designAnatomy(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
marginality = PBIBD2D.canon$marginality,
which.criteria = c('aeff', 'xeff', 'eeff','order'),
labels = "sources", orthogonalize = "eigen", data = PBIBD2.lay)
summary(PBIBD2Em.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_equal(length(PBIBD2Em.canon$marginality), 2)
testthat::expect_true(attr(PBIBD2Em.canon, which = "labels") == "sources")
#marginality list with trt NULL - same as supplying just unit marginality
PBIBD2Em.canon <-
designAnatomy(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
marginality = PBIBD2.marg,
which.criteria = c('aeff', 'xeff', 'eeff','order'),
labels = "sources", orthogonalize = "eigen", data = PBIBD2.lay)
summary(PBIBD2Em.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_equal(length(PBIBD2Em.canon$marginality), 2)
testthat::expect_true(attr(PBIBD2Em.canon, which = "labels") == "sources")
#full marginality list
PBIBD2Em.canon <-
designAnatomy(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
marginality = PBIBD2.marg,
which.criteria = c('aeff', 'xeff', 'eeff','order'),
labels = "sources", orthogonalize = "eigen", data = PBIBD2.lay)
summary(PBIBD2Em.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_equal(length(PBIBD2Em.canon$marginality), 2)
testthat::expect_true(attr(PBIBD2Em.canon, which = "labels") == "sources")
testthat::expect_true(all(names(PBIBD2Em.canon$marginality) == names(PBIBD2.marg)))
testthat::expect_lt(abs(PBIBD2Em.canon$Q[[1]]$'Units[Blocks]'$Treatments$adjusted$aefficiency -
0.8824), 1e-04)
#Add grand mean term
PBIBD2Egm.canon <-
designAnatomy(formulae = list(unit = ~Blocks/Units,
trt = ~ Treatments),
grandMean = TRUE, marginality = PBIBD2.marg,
which.criteria = c('aeff', 'xeff', 'eeff','order'),
labels = "sources", orthogonalize = "eigen", data = PBIBD2.lay)
summary(PBIBD2Egm.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_equal(length(PBIBD2Em.canon$marginality), 2)
testthat::expect_true(attr(PBIBD2Em.canon, which = "labels") == "sources")
testthat::expect_true(all(PBIBD2Egm.canon$terms$unit == c("Mean", "Blocks", "Blocks:Units")))
testthat::expect_true(all(PBIBD2Egm.canon$terms$trt == c("Mean", "Treatments")))
testthat::expect_true(all(names(PBIBD2Em.canon$marginality) == names(PBIBD2.marg)))
testthat::expect_lt(abs(PBIBD2Em.canon$Q[[1]]$'Units[Blocks]'$Treatments$adjusted$aefficiency -
0.8824), 1e-04)
#'## unique plot levels
PBIBD2.lay$AUnits <- with(PBIBD2.lay, fac.combine(list(Blocks,Units)))
PBIBD2A.canon <- designAnatomy(list(unit = ~Blocks + AUnits,
trt = ~ Treatments),
data = PBIBD2.lay, labels = "sources",
which.criteria = c('aeff', 'xeff', 'eeff','order'),
orthogonalize = "hybrid")
summary(PBIBD2A.canon, which.criteria = c('aeff', 'xeff', 'eeff','order'))
testthat::expect_lt(abs(PBIBD2A.canon$Q[[1]]$'AUnits[Blocks]'$Treatments$adjusted$aefficiency -
0.8824), 1e-04)
})
cat("#### Test for Jarrett & Ruggiero example\n")
test_that("JarrettRuggiero", {
skip_on_cran()
library(dae)
#'## Jarrett & Ruggiero example
jr.lay <- fac.gen(list(Set=7, Dye=2, Array=3))
jr.lay <- within(jr.lay,
{ Block <- factor(rep(1:7, each=6))
Plant <- factor(rep(c(1,2,3,2,3,1), times=7))
Sample <- factor(c(rep(c(2,1,2,2,1,1, 1,2,1,1,2,2), times=3), 2,1,2,2,1,1))
S1 <- Dye
Treat <- factor(c(1,2,4,2,4,1, 2,3,5,3,5,2, 3,4,6,4,6,3, 4,5,7,5,7,4,
5,6,1,6,1,5, 6,7,2,7,2,6, 7,1,3,1,3,7),
labels=c("A","B","C","D","E","F","G"))
})
array.plot.trt.canon <- designAnatomy(formulae = list(array = ~ (Set:Array)*Dye,
plot = ~ Block/Plant/Sample,
trt = ~ Treat),
labels = "sources", data = jr.lay)
testthat::expect_equal(length(array.plot.trt.canon$Q[[3]]), 7)
testthat::expect_equal(array.plot.trt.canon$Q[[3]]$`(Set:Array)#Dye&Sample[Block:Plant]`, 6)
testthat::expect_lt(abs(array.plot.trt.canon$Q[[2]]$`(Set:Array)#Dye&Plant[Block]`$Treat$adjusted$aefficiency - 0.58333333), 1e-05)
testthat::expect_lt(abs(array.plot.trt.canon$Q[[1]]$`(Set:Array)#Dye`$`Plant[Block]`$adjusted$aefficiency - 0.75), 1e-05)
summ.default <-summary(array.plot.trt.canon)
testthat::expect_equal(nrow(summ.default$decomp), 7)
testthat::expect_equal(ncol(summ.default$decomp), 9)
testthat::expect_false(is.null(attr(summ.default$aliasing, which = "title")))
summ.none <-summary(array.plot.trt.canon, which.criteria = "none")
testthat::expect_equal(ncol(summ.none$decomp), 6)
summ.all <-summary(array.plot.trt.canon, which.criteria = "all")
testthat::expect_equal(ncol(summ.all$decomp), 13)
summ.2 <-summary(array.plot.trt.canon, which.criteria =c("aefficiency", "order"))
testthat::expect_equal(ncol(summ.2$decomp), 8)
#with grand mean
apt.gm.canon <- designAnatomy(formulae = list(array = ~ (Set:Array)*Dye,
plot = ~ Block/Plant/Sample,
trt = ~ Treat),
grandMean = TRUE, labels = "sources", data = jr.lay)
summary(apt.gm.canon)
testthat::expect_equal(apt.gm.canon$Q[[3]]$`Mean&Mean&Mean`, 1)
#test eigen with supplied marginality for tier 2 only
plot.marg <- array.plot.trt.canon$marginality$plot
apt.tier2.canon <- designAnatomy(formulae = list(array = ~ (Set:Array)*Dye,
plot = ~ Block/Plant/Sample,
trt = ~ Treat),
marginality = list(plot = plot.marg), orthog = "eigen",
labels = "sources", data = jr.lay)
summary(apt.tier2.canon)
testthat::expect_true(all(apt.tier2.canon$sources$array ==
c("Set:Array", "Dye", "Set:Array:Dye")))
testthat::expect_true(all(apt.tier2.canon$sources$plot ==
c("Block", "Plant[Block]", "Sample[Block:Plant]")))
testthat::expect_equal(length(apt.tier2.canon$marginality), 3)
testthat::expect_equal(nrow(apt.tier2.canon$marginality$plot), 3)
apt.tier2.gm.canon <- designAnatomy(formulae = list(array = ~ (Set:Array)*Dye,
plot = ~ Block/Plant/Sample,
trt = ~ Treat),
marginality = list(plot = plot.marg), orthog = "eigen",
grandMean = TRUE, labels = "sources", data = jr.lay)
summary(apt.tier2.gm.canon)
testthat::expect_true(all(apt.tier2.gm.canon$sources$array ==
c("Mean", "Set:Array", "Dye", "Set:Array:Dye")))
testthat::expect_true(all(apt.tier2.gm.canon$sources$plot ==
c("Mean", "Block", "Plant[Block]", "Sample[Block:Plant]")))
testthat::expect_equal(length(apt.tier2.gm.canon$marginality), 3)
testthat::expect_equal(nrow(apt.tier2.gm.canon$marginality$plot), 3)
testthat::expect_equal(apt.tier2.gm.canon$Q[[3]]$`Mean&Mean&Mean`, 1)
})
cat("#### Test for Baby pseudoterm example\n")
test_that("Baby", {
skip_on_cran()
library(dae)
#'## Baby pseudoterm example
pseudo.lay <- data.frame(pl = factor(1:12),
ab = factor(rep(1:4, times=3)),
a = factor(rep(1:2, times=6)))
pseudo.canon <- designAnatomy(formulae = list(unit=~pl, trt=~a+ab),
labels = "sources", data = pseudo.lay)
summary(pseudo.canon)
testthat::expect_equal(pseudo.canon$Q[[2]]$'pl&ab[a]', 2)
pseudo.canon <- designAnatomy(formulae = list(unit=~pl, trt=~ab+a),
labels = "sources", data = pseudo.lay)
summ.hybrid <- summary(pseudo.canon)
testthat::expect_equal(nrow(summ.hybrid$aliasing), 2)
testthat::expect_equal(ncol(summ.hybrid$aliasing), 7)
testthat::expect_equal(pseudo.canon$Q[[2]]$'pl&ab', 3)
testthat::expect_equal(pseudo.canon$Q[[2]]$'pl&Residual', 8)
pseudo.canon <- designAnatomy(formulae = list(unit=~pl, trt=~ab+a),
orthogonalize = "diff",
labels = "sources", data = pseudo.lay)
summ.diff <- summary(pseudo.canon)
testthat::expect_equal(nrow(summ.diff$aliasing), 2)
testthat::expect_equal(ncol(summ.diff$aliasing), 7)
testthat::expect_equal(pseudo.canon$Q[[2]]$'pl&ab', 3)
testthat::expect_equal(pseudo.canon$Q[[2]]$'pl&Residual', 8)
pseudo.canon <- designAnatomy(formulae = list(unit=~pl, trt=~ab+a),
orthogonalize = "eigen",
labels = "sources", data = pseudo.lay)
summ.eigen <- summary(pseudo.canon)
testthat::expect_equal(nrow(summ.eigen$aliasing), 1)
testthat::expect_equal(ncol(summ.eigen$aliasing), 7)
testthat::expect_equal(pseudo.canon$Q[[2]]$'pl&ab', 3)
testthat::expect_equal(pseudo.canon$Q[[2]]$'pl&Residual', 8)
})
cat("#### Test for pseudoreplicated N experiment\n")
test_that("pseudoN", {
skip_on_cran()
library(dae)
#'## A design with the same RCBD in each Area
sameRCBD.lay <- designRandomize(allocated = fac.gen(list(Nitrogen = 3, 3, Varieties = 24)),
recipient = list(Areas = 3, Blocks = 3, Plots = 24),
nested.recipients = list(Plots = "Blocks"),
seed = 6411)
sameRCBD.lay <- within(sameRCBD.lay,
{
Plot <- fac.combine(list(Blocks,Plots))
})
testthat::expect_equal(nrow(sameRCBD.lay), 216)
testthat::expect_equal(ncol(sameRCBD.lay), 6)
#'### nested numbering of levels
sameRCBD.canon <- designAnatomy(formulae = list(unit = ~ Areas*(Blocks/Plots),
trt = ~ Nitrogen*Varieties),
data = sameRCBD.lay,
labels = "sources", grandMean = TRUE)
testthat::expect_true(all(unlist(sameRCBD.canon$Q[[2]]) == c(1,2,2,23,46,4,46,92)))
testthat::expect_equal(names(sameRCBD.canon$Q[[1]][4]), "Plots[Blocks]")
#Test for use of label.swap
summ.s <- summary(sameRCBD.canon, which = c('aeff','order'))
testthat::expect_equal(summ.s$decomp$Source.unit[4], "Plots[Blocks]")
summ.t <- summary(sameRCBD.canon, which = c('aeff','order'), labels.swap = TRUE)
testthat::expect_equal(summ.t$decomp$Term.unit[4], "Blocks:Plots")
testthat::expect_equal(names(sameRCBD.canon$Q[[1]][4]), "Plots[Blocks]")
#'### unique numbering of levels
sameRCBD.canon <- designAnatomy(formulae = list(unit = ~ Areas*(Blocks + Plot),
trt = ~ Nitrogen*Varieties),
labels = "sources", data = sameRCBD.lay)
summary(sameRCBD.canon, which = c('aeff','order'))
testthat::expect_true(all(unlist(sameRCBD.canon$Q[[2]]) == c(2,2,23,46,4,46,92)))
#'## A design with different RCBDs in each Area
diffRCBD.lay <- designRandomize(allocated = fac.gen(list(Nitrogen = 3, 3, Varieties = 24)),
recipient = list(Areas = 3, Blocks = 3, Plots = 24),
nested.recipients = list(Plots = "Blocks"),
seed = 6467)
diffRCBD.lay <- within(diffRCBD.lay,
{
Block <- fac.combine(list(Areas,Blocks))
Plot <- fac.combine(list(Areas,Blocks,Plots))
})
testthat::expect_equal(nrow(diffRCBD.lay), 216)
testthat::expect_equal(ncol(diffRCBD.lay), 7)
#'### nested numbering of levels
diffRCBD.canon <- designAnatomy(formulae = list(unit = ~ Areas/Blocks/Plots,
trt = ~ Nitrogen*Varieties),
data = diffRCBD.lay,
labels = "sources", grandMean = TRUE)
summary(diffRCBD.canon, which = c('aeff','order'))
testthat::expect_true(all(unlist(diffRCBD.canon$Q[[2]]) == c(1,2,6,23,46,138)))
#'### unique numbering of levels
diffRCBD.canon <- designAnatomy(formulae = list(unit = ~ Areas + Block + Plot,
trt = ~ Nitrogen*Varieties),
labels = "sources", data = diffRCBD.lay)
summary(diffRCBD.canon, which = c('aeff','order'))
testthat::expect_true(all(unlist(diffRCBD.canon$Q[[2]]) == c(2,6,23,46,138)))
#'### Use eigen and diff instead of hybrid
diffRCBD.canon <- designAnatomy(formulae = list(unit = ~ Areas + Block + Plot,
trt = ~ Nitrogen*Varieties),
data = diffRCBD.lay,
labels = "sources", grandMean = TRUE,
orthogonalize = c("eigen", "diff"))
summary(diffRCBD.canon, which = c('aeff','order'))
testthat::expect_true(all(unlist(diffRCBD.canon$Q[[2]]) == c(1,2,6,23,46,138)))
})
cat("#### Test for Repeated LSD for Housewives example\n")
test_that("Housewives", {
skip_on_cran()
library(dae)
data("LSRepeatHwife.dat")
Hwife.struct <- pstructure( ~ Month:Week + Month:Hwife +
Month:Week:Hwife,
labels = "sources", data = LSRepeatHwife.dat)
testthat::expect_equal(nrow(Hwife.struct$aliasing), 2)
testthat::expect_equal(ncol(Hwife.struct$aliasing), 10)
Hwife.canon <- designAnatomy(formulae = list(units = ~ Month:Week + Month:Hwife +
Month:Week:Hwife),
labels = "sources", data = LSRepeatHwife.dat)
summ <- summary(Hwife.canon)
testthat::expect_equal(nrow(summ$aliasing), 2)
testthat::expect_equal(ncol(summ$aliasing), 7)
testthat::expect_equal(nrow(Hwife.canon$aliasing), 2)
testthat::expect_equal(ncol(Hwife.canon$aliasing), 11)
testthat::expect_equal(Hwife.canon$Q[[1]]$`Month:Week`, 7)
testthat::expect_equal(Hwife.canon$Q[[1]]$`Month:Hwife`, 6)
testthat::expect_equal(Hwife.canon$Q[[1]]$`Week#Hwife[Month]`, 18)
testthat::expect_error(Hwife.diff.canon <- designAnatomy(formulae = list(units = ~ Month:Week + Month:Hwife +
Month:Week:Hwife),
labels = "sources",
orthogonalize = "diff", data = LSRepeatHwife.dat))
})
cat("#### Test for Preece examples\n")
test_that("Preece", {
skip_on_cran()
library(dae)
#'## Preece examples with two sets of treatments in a BIBD
#'### two tiers
preece1.lay <- fac.gen(list(block=10, plot=3))
preece1.lay$T1 <- factor(c(1,3,4, 2,4,5, 3,5,1, 4,1,2, 5,2,3,
1,2,5, 2,3,1, 3,4,2, 4,5,3, 5,1,4))
preece1.lay$T2 <- factor(c(1,2,5, 2,3,1, 3,4,2, 4,5,3, 5,1,4,
1,4,3, 2,5,4, 3,1,5, 4,2,1, 5,3,2))
preece1.lay$T3 <- factor(c(1,4,3, 2,5,4, 3,1,5, 4,2,1, 5,3,2,
1,5,2, 2,1,3, 3,2,4, 4,3,5, 5,4,1))
preece1.canon <- designAnatomy(formulae = list(plot= ~ block/plot, trt= ~ T1+T2),
labels = "sources", data = preece1.lay)
summary(preece1.canon, which.criteria = c("aeff", "order"))
testthat::expect_equal(length(preece1.canon$Q[[1]]), 2)
testthat::expect_equal(length(preece1.canon$Q[[1]]$block), 3)
testthat::expect_equal(length(preece1.canon$Q[[1]]$`plot[block]`), 3)
testthat::expect_lt(abs(preece1.canon$Q[[1]]$block$T1$adjusted$aefficiency - 0.1666667), 1e-05)
testthat::expect_lt(abs(preece1.canon$Q[[1]]$block$T2$adjusted$aefficiency - 0.0952), 1e-04)
testthat::expect_lt(abs(preece1.canon$Q[[1]]$`plot[block]`$T1$adjusted$aefficiency - 0.8333333), 1e-05)
testthat::expect_lt(abs(preece1.canon$Q[[1]]$`plot[block]`$T2$adjusted$aefficiency - 0.7619), 1e-04)
testthat::expect_equal(preece1.canon$Q[[2]]$'block&T1', 4)
testthat::expect_equal(preece1.canon$Q[[2]]$'block&T2', 4)
testthat::expect_equal(preece1.canon$Q[[2]]$'block&Residual', 1)
testthat::expect_equal(preece1.canon$Q[[2]]$'plot[block]&T1', 4)
testthat::expect_equal(preece1.canon$Q[[2]]$'plot[block]&T2', 4)
testthat::expect_equal(preece1.canon$Q[[2]]$'plot[block]&Residual', 12)
preece2.canon <- designAnatomy(formulae = list(plot= ~ block/plot, trt= ~ T1+T3),
labels = "sources", data = preece1.lay)
summary(preece2.canon)
testthat::expect_equal(length(preece2.canon$Q[[1]]), 2)
testthat::expect_equal(length(preece2.canon$Q[[1]]$block), 2)
testthat::expect_equal(length(preece2.canon$Q[[1]]$`plot[block]`), 3)
testthat::expect_lt(abs(preece2.canon$Q[[1]]$block$T1$adjusted$aefficiency - 0.1666667), 1e-05)
testthat::expect_lt(abs(preece2.canon$Q[[1]]$`plot[block]`$T1$adjusted$aefficiency - 0.8333333), 1e-05)
testthat::expect_lt(abs(preece2.canon$Q[[1]]$`plot[block]`$T3$adjusted$aefficiency - 0.8571), 1e-04)
testthat::expect_equal(preece2.canon$Q[[2]]$'block&T1', 4)
testthat::expect_equal(preece2.canon$Q[[2]]$'block&Residual', 5)
testthat::expect_equal(preece2.canon$Q[[2]]$'plot[block]&T1', 4)
testthat::expect_equal(preece2.canon$Q[[2]]$'plot[block]&T3', 4)
testthat::expect_equal(preece2.canon$Q[[2]]$'plot[block]&Residual', 12)
})
cat("#### Test for Mostafa's green wall experiment in 2014\n")
test_that("Mostafa", {
skip_on_cran()
library(dae)
#Mostafa's green wall experiment in 2014
data(gwall.lay)
options(width = 100, nwarnings = 150)
set.daeTolerance(1e-06, 1e-06)
pot.treat.canon <- designAnatomy(formulae = list(pot = ~ Rows*Cols,
trt = ~ Species*Irrigation*Media +
First/(SpeCarry*IrrCarry*MedCarry)),
labels = "sources", data = gwall.lay,
keep.order=TRUE)
summary(pot.treat.canon)
testthat::expect_equal(length(pot.treat.canon$Q[[2]]), 17)
testthat::expect_equal(pot.treat.canon$Q[[2]]$`Rows#Cols&Residual`, 69)
testthat::expect_lt(abs(pot.treat.canon$Q[[1]]$`Rows#Cols`$`Species#Irrigation#Media`$adjusted$aefficiency - 0.8240828), 1e-05)
testthat::expect_lt(abs(pot.treat.canon$Q[[1]]$`Rows#Cols`$`SpeCarry#IrrCarry[First]`$adjusted$aefficiency - 0.8320062), 1e-05)
trt.struct <- pstructure(formula = ~ Species*Irrigation*Media +
First/(SpeCarry*IrrCarry*MedCarry),
labels = "sources", data = gwall.lay)
testthat::expect_true(all(names(trt.struct$Q) == c("Species","Irrigation","Species#Irrigation",
"Media","Species#Media","Irrigation#Media",
"Species#Irrigation#Media","First",
"SpeCarry[First]","IrrCarry[First]",
"SpeCarry#IrrCarry[First]")))
#use designAnatomy to call pstructure
trt.canon <- designAnatomy(list(trt = ~ Species*Irrigation*Media +
First/(SpeCarry*IrrCarry*MedCarry)),
labels = "sources", data = gwall.lay)
testthat::expect_true(all(names(trt.canon$Q) == c("Species","Irrigation","Species#Irrigation",
"Media","Species#Media","Irrigation#Media",
"Species#Irrigation#Media","First",
"SpeCarry[First]","IrrCarry[First]",
"SpeCarry#IrrCarry[First]")))
})
cat("#### Test for four-tiered corn example\n")
test_that("corn", {
skip_on_cran()
library(dae)
#'## Four-tiered corn experiment with 3 structures including pseudoterms
#'### Randomize field factors to lab factors
corn1.recip <- list(Intervals=18, ConPlate=36)
corn1.nest <- list(ConPlate = "Intervals")
corn1.alloc <- fac.gen(list(Sites=3, Blocks=2, Plots=3, Lots=36))
#corn1.alloc$Harvesters <- factor(1:3, each=36, times=6)
corn1.lay <- designRandomize(allocated = corn1.alloc,
recipient = corn1.recip,
nested.recipients = corn1.nest,
seed = 81505)
#'### Randomize treatments to lab factors
corn2.recip <- list(Intervals=18, Containers=9, Plates=4)
corn2.nest <- list(Containers = "Intervals", Plates = c("Containers", "Intervals"))
Treats <- factor(rep(1:9, each=4, times=18))
corn2.lay <- designRandomize(allocated = Treats,
recipient = corn2.recip,
nested.recipients = corn2.nest,
seed = 543205)
corn2.lay <- corn2.lay[-1]
#'### Randomize Harvesters to field factors
corn3.recip <- list(Sites=3, Blocks=2, Plots=3, Lots=36)
corn3.nest <- list(Blocks = "Sites", Plots = c("Blocks", "Sites"), Lots = c("Plots", "Blocks", "Sites"))
Harvesters <- factor(rep(1:3, each=36, times=6))
corn3.lay <- designRandomize(allocated = Harvesters,
recipient = corn3.recip,
nested.recipients = corn3.nest,
seed = 135205)
#'### Combine randomizations
corn.lay <- cbind(corn1.lay, corn2.lay)
corn.lay <- merge(corn.lay, corn3.lay)
corn.lay <- corn.lay[c("Intervals", "Containers", "Plates", "ConPlate",
"Sites", "Blocks", "Plots", "Lots",
"Treats", "Harvesters")]
corn.lay <- corn.lay[do.call(order, corn.lay), ]
rownames(corn.lay) <- NULL
#'### Make factors with unique levels
corn.lay <- within(corn.lay,
{
AContainers <- fac.combine(list(Intervals, Containers))
APlates <- fac.combine(list(AContainers, Plates))
ABlocks <- fac.combine(list(Sites, Blocks))
APlots <- fac.combine(list(ABlocks, Plots))
ALots <- fac.combine(list(APlots, Lots))
})
#'## Check properties
corn.canon <- designAnatomy(formulae = list(plate= ~ Intervals + AContainers + APlates,
field= ~ Sites + ABlocks + APlots + ALots,
trts= ~ Sites*Harvesters*Treats),
labels = "sources", data = corn.lay)
summary(corn.canon, which.criteria="aeff")
testthat::expect_equal(corn.canon$Q[[3]]$`Intervals&APlots[Sites:ABlocks]&Residual`, 6)
testthat::expect_equal(corn.canon$Q[[3]]$`AContainers[Intervals]&ALots[Sites:ABlocks:APlots]&Residual`,
72)
testthat::expect_equal(corn.canon$Q[[3]]$`APlates[Intervals:AContainers]&ALots[Sites:ABlocks:APlots]`,
486)
#Create an example with double Residual
corn2Res.canon <- designAnatomy(formulae = list(plate= ~ AContainers + APlates,
field= ~ Sites + ABlocks + ALots,
fldtrts= ~ Harvesters,
labtrts= ~ Treats),
labels = "sources", data = corn.lay)
summary(corn2Res.canon, which.criteria="none")
testthat::expect_equal(corn2Res.canon$Q[[4]]$`AContainers&ALots[Sites:ABlocks]&Residual&Treats`,
8)
testthat::expect_equal(corn2Res.canon$Q[[4]]$`AContainers&ALots[Sites:ABlocks]&Residual&Residual`,
146)
})
cat("#### Test for Piepho example with pseudoreplication\n")
test_that("Piepho", {
skip_on_cran()
library(dae)
#'## Piepho example with pseudoreplication
data('PiephoLSDRand')
piepho.canon <- designAnatomy(formulae = list(lab= ~ Times/(Locations*Ovens),
field= ~ Block/Plot/Sample,
trt= ~ Harvest*Method),
labels = "sources", data = Piepho_LSD_Rand)
summary(piepho.canon, which.criteria="aeff")
testthat::expect_equal(piepho.canon$Q[[3]]$"Times&Plot[Block]&Harvest", 3)
testthat::expect_equal(piepho.canon$Q[[3]]$"Locations[Times]&Block", 2)
testthat::expect_equal(piepho.canon$Q[[3]]$"Locations[Times]&Plot[Block]", 6)
testthat::expect_equal(piepho.canon$Q[[3]]$"Ovens[Times]&Sample[Block:Plot]", 8)
testthat::expect_equal(piepho.canon$Q[[3]]$"Locations#Ovens[Times]&Sample[Block:Plot]&Method",2)
testthat::expect_equal(piepho.canon$Q[[3]]$"Locations#Ovens[Times]&Sample[Block:Plot]&Harvest#Method", 6)
testthat::expect_equal(piepho.canon$Q[[3]]$"Locations#Ovens[Times]&Sample[Block:Plot]&Residual", 8)
Piepho_LSD_Rand <- within(Piepho_LSD_Rand,
{
ALocations <- fac.combine(list(Times, Locations))
AOvens <- fac.combine(list(Times, Ovens))
APositions <- fac.combine(list(Times, Locations, Ovens))
APlot <- fac.combine(list(Block, Plot))
ASample <- fac.combine(list(Block, Plot, Sample))
})
piephoA.canon <- designAnatomy(formulae = list(lab= ~ Times + ALocations + AOvens + APositions,
field= ~ Block + APlot + ASample,
trt= ~ Harvest*Method),
labels = "sources", data = Piepho_LSD_Rand)
summary(piephoA.canon, which.criteria="aeff")
testthat::expect_equal(piephoA.canon$Q[[3]]$"Times&APlot[Block]&Harvest", 3)
testthat::expect_equal(piephoA.canon$Q[[3]]$"ALocations[Times]&Block", 2)
testthat::expect_equal(piephoA.canon$Q[[3]]$"ALocations[Times]&APlot[Block", 6)
testthat::expect_equal(piephoA.canon$Q[[3]]$"AOvens[Times]&ASample[Block:APlot]", 8)
testthat::expect_equal(piephoA.canon$Q[[3]]$"APositions[Times]&ASample[Block:APlot]&Method",2)
testthat::expect_equal(piephoA.canon$Q[[3]]$"APositions[Times]&ASample[Block:APlot]&Harvest#Method", 6)
testthat::expect_equal(piephoA.canon$Q[[3]]$"APositions[Times]&ASample[Block:APlot]&Residual", 8)
})
cat("#### FAME example with complicated pseudoterm structure\n")
test_that("FAME", {
skip_on_cran()
library(dae)
"FAME example with complicated pseudoterm structure"
data('FAME')
FAME[c("Int1","Int2","Int3","Int4","Int5","Int6")] <-
lapply(FAME[c("Int1","Int2","Int3","Int4","Int5","Int6")], factor)
fame.canon <- designAnatomy(formulae = list(lab= ~ Int1:Int2:Int3/Int4/Int5/Int6,
field= ~ ((Block/Plot)*Depth)/Sample,
trt= ~ Tillage*Depth*Method),
labels = "sources", data = FAME)
summary(fame.canon, which.criteria="aeff")
testthat::expect_equal(length(fame.canon$Q[[2]]), 14)
testthat::expect_equal(length(fame.canon$Q[[3]]), 20)
testthat::expect_equal(fame.canon$Q[[3]]$'Int1:Int2:Int3&Sample[Block:Plot:Depth]&Residual', 1)
testthat::expect_equal(fame.canon$Q[[3]]$'Int5[Int1:Int2:Int3:Int4]&Plot[Block]&Residual', 3)
testthat::expect_equal(fame.canon$Q[[3]]$'Int5[Int1:Int2:Int3:Int4]&Sample[Block:Plot:Depth]&Residual', 3)
testthat::expect_equal(fame.canon$Q[[3]]$'Int6[Int1:Int2:Int3:Int4:Int5]&Plot#Depth[Block]&Residual', 3)
testthat::expect_equal(fame.canon$Q[[3]]$'Int6[Int1:Int2:Int3:Int4:Int5]&Sample[Block:Plot:Depth]&Residual', 6)
#Form factors with unique levels
FAME <- within(FAME,
{
Int2 <- fac.combine(list(Int1,Int2))
Int3 <- fac.combine(list(Int2,Int3))
Int4 <- fac.combine(list(Int3,Int4))
Int5 <- fac.combine(list(Int4,Int5))
Int6 <- fac.combine(list(Int5,Int6))
Plot <- fac.combine(list(Block,Plot))
Sample <- fac.combine(list(Plot,Depth,Sample))
})
fameA.canon <- designAnatomy(formulae = list(lab= ~ Int3 + Int4 + Int5 + Int6,
field= ~ (Block + Plot)*Depth + Sample,
trt= ~ Tillage*Depth*Method),
labels = "sources", data = FAME)
summary(fameA.canon, which.criteria="aeff")
testthat::expect_equal(length(fameA.canon$Q[[2]]), 14)
testthat::expect_equal(length(fameA.canon$Q[[3]]), 20)
testthat::expect_equal(fameA.canon$Q[[3]]$'Int3&Sample[Block:Plot:Depth]&Residual', 1)
testthat::expect_equal(fameA.canon$Q[[3]]$'Int5[Int3:Int4]&Plot[Block]&Residual', 3)
testthat::expect_equal(fameA.canon$Q[[3]]$'Int5[Int3:Int4]&Sample[Block:Plot:Depth]&Residual', 3)
testthat::expect_equal(fameA.canon$Q[[3]]$'Int6[Int3:Int4:Int5]&Plot#Depth[Block]&Residual', 3)
testthat::expect_equal(fameA.canon$Q[[3]]$'Int6[Int3:Int4:Int5]&Sample[Block:Plot:Depth]&Residual', 6)
})
cat("#### Test for Piracicaba Euc pulp example\n")
test_that("EucPulp", {
skip_on_cran()
library(dae)
"Piracicaba Euc pulp example- an example with no Residuals"
data('EucPulp2x2')
euc.canon <- designAnatomy(formulae = list(lab= ~ Runs/Positions,
cook= ~ Cookings/Samples,
trt= ~ ((Kinds*Ages)/Lots/Batches)*Times),
labels = "sources", data = Euc_Pulp2x2)
summary(euc.canon, which.criteria="aeff")
testthat::expect_equal(length(euc.canon$Q[[3]]), 11)
testthat::expect_equal(euc.canon$Q[[3]]$'Runs&Cookings&Batches[Kinds:Ages:Lots]', 36)
testthat::expect_equal(euc.canon$Q[[3]]$'Positions[Runs]&Samples[Cookings]&Batches#Times[Kinds:Ages:Lots]', 180)
})
cat("#### Test for Split plot with rows and columns in main and split-plots\n")
test_that("SpliPlotRowsColumns", {
skip_on_cran()
library(dae)
#'## Split plot with rows and columns in main and split-plots
data('LS4.CC4x4.1a')
split.recip <- LS4_CC4x4_1a[, 1:4]
split.nest <- list(SubCols = "BigRows")
split.trt <- LS4_CC4x4_1a[, 5:8]
split.layout <- designRandomize(allocated = split.trt,
recipient = split.recip,
nested.recipients = split.nest,
seed = 7154)
#'### Check design
split.canon <- designAnatomy(formulae = list(plot= ~ ((BigRows/SubCols)*BigCols)*SubRows,
trts= ~ Soils*Varieties*TreatB*MF),
labels = "sources", data = split.layout)
summary(split.canon, which.criteria=c("aeff","ord"))
testthat::expect_equal(length(split.canon$Q[[1]]), 11)
testthat::expect_equal(split.canon$Q[[1]]$'SubCols[BigRows]'$'Soils#TreatB#MF'$adjusted$aefficiency, 0.25)
testthat::expect_equal(split.canon$Q[[1]]$'SubCols#BigCols[BigRows]'$'Soils#TreatB#MF'$adjusted$aefficiency, 0.75)
testthat::expect_equal(split.canon$Q[[1]]$'SubCols#SubRows[BigRows]'$'Soils#Varieties#TreatB#MF'$adjusted$aefficiency, 0.25)
testthat::expect_equal(split.canon$Q[[1]]$'SubCols#BigCols#SubRows[BigRows]'$'Soils#Varieties#TreatB#MF'$adjusted$aefficiency, 0.75)
testthat::expect_equal(split.canon$Q[[2]]$'SubCols#BigCols#SubRows[BigRows]&Residual', 72)
Q.plot <- pstructure( ~ ((BigRows/SubCols)*BigCols)*SubRows,
labels = "sources", data = split.layout)
names (Q.plot)
split.layout <- within(split.layout,
{
ASubCols <- fac.combine(list(BigRows, SubCols))
})
splitA.canon <- designAnatomy(formulae = list(plot= ~ ((BigRows + ASubCols)*BigCols)*SubRows,
trts= ~ Soils*Varieties*TreatB*MF),
labels = "sources", data = split.layout)
summary(splitA.canon, which.criteria=c("aeff","ord"))
testthat::expect_equal(length(splitA.canon$Q[[1]]), 11)
testthat::expect_equal(splitA.canon$Q[[1]]$'ASubCols[BigRows]'$'Soils#TreatB#MF'$adjusted$aefficiency, 0.25)
testthat::expect_equal(splitA.canon$Q[[1]]$'ASubCols#BigCols[BigRows]'$'Soils#TreatB#MF'$adjusted$aefficiency, 0.75)
testthat::expect_equal(splitA.canon$Q[[1]]$'ASubCols#SubRows[BigRows]'$'Soils#Varieties#TreatB#MF'$adjusted$aefficiency, 0.25)
testthat::expect_equal(splitA.canon$Q[[1]]$'ASubCols#BigCols#SubRows[BigRows]'$'Soils#Varieties#TreatB#MF'$adjusted$aefficiency, 0.75)
testthat::expect_equal(splitA.canon$Q[[2]]$'ASubCols#BigCols#SubRows[BigRows]&Residual', 72)
})
cat("#### Test for EXP249 - a two-phae, p-rep design\n")
test_that("Exp249", {
skip_on_cran()
library(dae)
data(file="Exp249.mplot.sys")
Exp249.mplot.sys$Blocks <- factor(rep(1:6, each = 44))
#'## Expand design to rerandomize lines and to assign conditions to locations
Exp249.recip <- list(Groups = 6, Columns = 4, Pairs = 11, Locations = 2)
Exp249.nest <- list(Columns = c("Groups", "Pairs"),
Locations = c("Groups", "Columns", "Pairs"))
Exp249.alloc <- data.frame(Lines = factor(rep(Exp249.mplot.sys$Lines, each=2),
levels=1:75),
Checks = fac.recode(rep(Exp249.mplot.sys$Lines, each=2),
newlevels=c(rep(3, 73), 1 , 2),
labels = c("NAM","Scout","Gladius")),
Conditions = factor(rep(1:2, times=264),
labels = c('0 NaCl','100 NaCl')))
Exp249.lay <- designRandomize(allocated = Exp249.alloc,
recipient = Exp249.recip,
nested.recipients = Exp249.nest,
seed = 51412)
#'## Add second-phase factors
#'## (to which the first-phase factors have been systematically allocated)
Exp249.lay <- cbind(fac.gen(list(Lanes = 24, Positions = 2:23)),
fac.gen(list(Zones = 6, Rows = 4, MainPosn = 11, Subplots = 2)),
Exp249.lay)
#'## Check design properties
Exp249.canon <- designAnatomy(formulae = list(carts = ~(Zones*MainPosn)/Rows/Subplots,
tables = ~(Groups*Pairs)/Columns/Locations,
treats = ~(Checks + Lines) * Conditions),
labels = "sources", data = Exp249.lay)
summary(Exp249.canon)
testthat::expect_equal(length(Exp249.canon$Q[[1]]), 5)
testthat::expect_lt(abs(Exp249.canon$Q[[2]]$'Zones&Groups'$'Lines'$adjusted$aefficiency - 0.1498311), 1e-05)
testthat::expect_lt(abs(Exp249.canon$Q[[2]]$'Rows[Zones:MainPosn]&Columns[Groups:Pairs]'$'Lines'$adjusted$aefficiency - 0.6639769), 1e-05)
testthat::expect_lt(abs(Exp249.canon$Q[[2]]$'Subplots[Zones:MainPosn:Rows]&Locations[Groups:Pairs:Columns]'$'Conditions'$adjusted$aefficiency - 1), 1e-05)
testthat::expect_equal(Exp249.canon$Q[[3]]$'Rows[Zones:MainPosn]&Columns[Groups:Pairs]&Residual', 124)
testthat::expect_equal(Exp249.canon$Q[[3]]$'Subplots[Zones:MainPosn:Rows]&Locations[Groups:Pairs:Columns]&Residual', 189)
#'## Add factors and variates for new analysis
Exp249.lay <- within(Exp249.lay,
{ xMainPosn <- as.numfac(MainPosn)
xMainPosn <- -(xMainPosn - mean(xMainPosn))
Mainplots <- fac.combine(list(Rows,MainPosn))
})
#'## Check properties if only linear trend fitted
Exp249.canon <- designAnatomy(formulae = list(cart = ~Zones/Mainplots/Subplots,
treat = ~xMainPosn + (Checks + Lines) * Conditions),
data = Exp249.lay,
labels = "sources", orthogonalize = c("diff", "eigenmethods"))
summ <- summary(Exp249.canon)
testthat::expect_equal(nrow(summ$aliasing), 2)
testthat::expect_equal(ncol(summ$aliasing), 7)
testthat::expect_equal(length(Exp249.canon$Q[[1]]), 3)
testthat::expect_lt(abs(Exp249.canon$Q[[1]]$'Zones'$'Lines'$adjusted$aefficiency - 0.1499827), 1e-05)
testthat::expect_lt(abs(Exp249.canon$Q[[1]]$'Mainplots[Zones]'$'Lines'$adjusted$aefficiency - 0.987877), 1e-05)
testthat::expect_lt(abs(Exp249.canon$Q[[1]]$'Subplots[Zones:Mainplots]'$'Conditions'$adjusted$aefficiency - 1), 1e-05)
testthat::expect_equal(Exp249.canon$Q[[2]]$'Mainplots[Zones]&Residual', 183)
testthat::expect_equal(Exp249.canon$Q[[2]]$'Subplots[Zones:Mainplots]&Residual', 189)
Exp249.lay <- within(Exp249.lay,
{
AMainplots <- fac.combine(list(Zones, Mainplots))
ASubplots <- fac.combine(list(AMainplots,Subplots))
})
Exp249A.canon <- designAnatomy(formulae = list(cart = ~Zones + AMainplots + ASubplots,
treat = ~xMainPosn + (Checks + Lines) * Conditions),
labels = "sources", data = Exp249.lay)
summary(Exp249A.canon)
testthat::expect_equal(length(Exp249.canon$Q[[1]]), 3)
testthat::expect_lt(abs(Exp249A.canon$Q[[1]]$'Zones'$'Lines[Checks]'$adjusted$aefficiency - 0.1499827), 1e-05)
testthat::expect_lt(abs(Exp249A.canon$Q[[1]]$'AMainplots[Zones]'$'Lines[Checks]'$adjusted$aefficiency - 0.987877), 1e-05)
testthat::expect_lt(abs(Exp249A.canon$Q[[1]]$'ASubplots[Zones:AMainplots]'$'Conditions'$adjusted$aefficiency - 1), 1e-05)
testthat::expect_equal(Exp249A.canon$Q[[2]]$'AMainplots[Zones]&Residual', 183)
testthat::expect_equal(Exp249A.canon$Q[[2]]$'ASubplots[Zones:AMainplots]&Residual', 189)
})
cat("#### Test for Brien and Payne 3-tier sensory experiment\n")
test_that("Sensory3tier", {
skip_on_cran()
library(dae)
#Three-tier sensory experiment
data("Need3.dat")
#Do short names version
names(Need3.dat)[match(c("Occasions", "Intervals", "Sittings", "Positions", "Judges",
"Squares", "Rows", "Columns", "Halfplots"), names(Need3.dat))] <-
c("Occ", "Int", "Sit", "Pos", "Jud", "Sqr", "Row", "Col", "HPlot")
#'## Complete decomposition
Eval.Field.Treat.canon <- designAnatomy(list(eval=~ ((Occ/Int/Sit)*Jud)/Pos,
field=~ (Row*(Sqr/Col))/HPlot,
treats=~ Trellis*Method),
labels = "sources", data=Need3.dat)
summary(Eval.Field.Treat.canon, which.criteria =c("aefficiency", "order"))
testthat::expect_equal(names(Eval.Field.Treat.canon$Q[[1]]),
c("Occ","Int[Occ]","Sit[Occ:Int]","Jud","Occ#Jud","Int#Jud[Occ]",
"Sit#Jud[Occ:Int]","Pos[Occ:Int:Sit:Jud]"))
testthat::expect_equal(names(Eval.Field.Treat.canon$Q[[2]]),
c("Occ&Sqr","Int[Occ]","Sit[Occ:Int]&Col[Sqr]","Sit[Occ:Int]&Residual",
"Jud","Occ#Jud","Int#Jud[Occ]&Row","Int#Jud[Occ]&Row#Sqr",
"Int#Jud[Occ]&Residual","Sit#Jud[Occ:Int]&Col[Sqr]",
"Sit#Jud[Occ:Int]&Row#Col[Sqr]","Sit#Jud[Occ:Int]&Residual",
"Pos[Occ:Int:Sit:Jud]&HPlot[Row:Sqr:Col]",
"Pos[Occ:Int:Sit:Jud]&Residual"))
testthat::expect_equal(names(Eval.Field.Treat.canon$Q[[3]]),
c("Occ&Sqr","Int[Occ]","Sit[Occ:Int]&Col[Sqr]&Trellis",
"Sit[Occ:Int]&Col[Sqr]&Residual","Sit[Occ:Int]&Residual",
"Jud","Occ#Jud","Int#Jud[Occ]&Row","Int#Jud[Occ]&Row#Sqr",
"Int#Jud[Occ]&Residual","Sit#Jud[Occ:Int]&Col[Sqr]&Trellis",
"Sit#Jud[Occ:Int]&Col[Sqr]&Residual","Sit#Jud[Occ:Int]&Row#Col[Sqr]&Trellis",
"Sit#Jud[Occ:Int]&Row#Col[Sqr]&Residual","Sit#Jud[Occ:Int]&Residual",
"Pos[Occ:Int:Sit:Jud]&HPlot[Row:Sqr:Col]&Method",
"Pos[Occ:Int:Sit:Jud]&HPlot[Row:Sqr:Col]&Trellis#Method",
"Pos[Occ:Int:Sit:Jud]&HPlot[Row:Sqr:Col]&Residual",
"Pos[Occ:Int:Sit:Jud]&Residual"))
testthat::expect_equal(Eval.Field.Treat.canon$Q[[3]]$'Sit#Jud[Occ:Int]&Col[Sqr]&Trellis', 3)
testthat::expect_equal(Eval.Field.Treat.canon$Q[[3]]$'Sit#Jud[Occ:Int]&Col[Sqr]&Residual', 3)
testthat::expect_equal(Eval.Field.Treat.canon$Q[[3]]$'Sit#Jud[Occ:Int]&Row#Col[Sqr]&Trellis', 3)
testthat::expect_equal(Eval.Field.Treat.canon$Q[[3]]$'Sit#Jud[Occ:Int]&Row#Col[Sqr]&Residual', 9)
summ <- summary(Eval.Field.Treat.canon, which.criteria =c("aefficiency", "order"))
testthat::expect_true(all(abs(summ$decomp[11:14,7] -
c(0.07407407,0.66666667,0.88888889,1.00000000)) < 1e-06))
})
Try the dae package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.