# Tests "commonality" function
context("Compute qq function from tt matrix")
library(dst)
test_that("commonality", {
# T0
# Check case where commonalities are computed after
y1 <- bca(tt = matrix(c(0,1,1,1,1,0,1,1,1),nrow = 3,
byrow = TRUE), m = c(0.2,0.5, 0.3),
cnames = c("a", "b", "c"),
varnames = "x", idvar = 1)
y2 <- bca(tt = matrix(c(1,0,0,1,1,1),nrow = 2,
byrow = TRUE), m = c(0.6, 0.4),
cnames = c("a", "b", "c"),
varnames = "x", idvar = 1)
z <- dsrwon(y1,y2)
q1 <- commonality(ppm$tt, m = ppm$spec[,2], method = "ezt")
q2 <- commonality(ppm$tt, m = ppm$spec[,2], method = "ezt-m")
expect_equal(q1,q2)
# T1
# Check combination with qq is the same as combination with tt
# by checking commonality function of the bca is same of the combined commonality function
x <- bca(tt = matrix(c(0,1,1,1,1,0,1,1,1),nrow = 3,
byrow = TRUE), m = c(0.2,0.5, 0.3),
cnames = c("a", "b", "c"), varnames = "x", idvar = 1, method="fzt")
y <- bca(tt = matrix(c(1,0,0,1,1,1),nrow = 2,
byrow = TRUE), m = c(0.6, 0.4),
cnames = c("a", "b", "c"), varnames = "y", idvar = 1, method="fzt")
z <- dsrwon(x,y)
w <- dsrwon(x,y,use_qq = TRUE)
expect_equal(q,w$qq)
# T2.
# Test agreement between fzt, ezt
ttxl <- lapply(1:nrow(z$tt), function(i) z$tt[i, ])
ttyl <- closure(ttxl,TRUE)
ttzl <- do.call(rbind, ttyl)
colnames(ttzl) <- c("a", "b", "c")
rownames(ttzl) <- nameRows(ttzl)
q <- commonality(ttzl,c(z$spec[,2],0),method="ezt")
expect_equal(q,w$qq[names(q)])
#T2.1 test fzt vs ezt
tt6 <- matrix(c(0,0,0,0,0,0,
1,0,0,0,0,0,
0,0,0,1,0,0,
1,0,0,1,0,0,
0,0,1,1,0,1,
1,0,1,1,0,1,
1,1,1,1,1,1), nrow = 7, byrow = TRUE)
cnames6 <- c("a","b","c","d","e","f")
m6 <- c(0.01,0.02,0.03,0.04,0.05,0.06,0.79)
x6 <- bca(tt6,m6,cnames=cnames6)
x6n <- nzdsr(x6)
q1 <- commonality(x6n$tt,x6n$spec[,2], method="fzt")
q2 <- commonality(x6n$tt,x6n$spec[,2], method="ezt")
expect_equal(q1[names(q2)],q2)
# T2.2
# Test fzt vs ezt
x61 <- bca(tt6, m6, cnames=cnames6, method="fzt")
x62 <- bca(tt6, m6, cnames=cnames6, method="ezt")
expect_equal(x61$qq[names(x62$qq)],x62$qq)
# T2.3
# Other test of agreement
# Subset data
n <- 5
m <- 10
# Sample S
S <- 3
set.seed(1)
e <- sample.int(m,S)
# Sample b
b0 <- rnorm(S, sd=0.6)
b <- rep(0,m)
b[e] <- b0
# Sample X
m0 <- matrix(0, n, m)
X <- apply(m0, c(1,2), function(x) sample(c(0,1),1))
Xb <- X %*% b
# Set outcome
y <- runif(length(Xb)) < 1/(1 + exp(-Xb))
# Parameter
a <- 1e-3
# Regular combination
rsid <- 1:m
bma <- bca(rbind(if (y[1]>0) X[1,1:m] >= 1 else
(1-X[1,1:m]) >= 1,rep(1,m)), c(a,1-a),
cnames=rsid)
for(i in 2:n) {
print(i)
bma_new <- bca(rbind(if (y[i]>0) X[i,1:m] >= 1 else
(1-X[i,1:m]) >= 1,rep(1,m)), c(a,1-a),
cnames=rsid)
bma <- dsrwon(bma,bma_new,use_ssnames = TRUE)
}
q1=commonality(bma$tt, bma$spec[,2], method = "fzt")
q2=commonality(bma$tt, bma$spec[,2], method = "ezt")
expect_equal(q1[names(q2)],q2)
# T3.
# Test ezt on combination
x <- bca(tt = matrix(c(1,1,0,1,1,1), nrow = 2,
byrow = TRUE), m = c(0.4, 0.6), method="fzt",
cnames = c("a", "b", "c"), varnames = "x", idvar = 1)
y <- bca(tt = matrix(c(0,1,1,1,1,1), nrow = 2,
byrow = TRUE), m = c(0.3, 0.7), method="fzt",
cnames = c("a", "b", "c"), varnames = "y", idvar = 2)
w <- dsrwon(x,y,use_qq = TRUE)
ttx <- matrix(c(1,1,0,1,1,1), nrow = 2,
byrow = TRUE)
tty <- matrix(c(0,1,1,1,1,1), nrow = 2,
byrow = TRUE)
x <- bca(tt = ttx, m = c(0.4, 0.6), method="ezt",
cnames = c("a", "b", "c"), varnames = "x", idvar = 1)
y <- bca(tt = tty, m = c(0.3, 0.7), method="ezt",
cnames = c("a", "b", "c"), varnames = "y", idvar = 2)
z <- dsrwon(x,y,use_qq = TRUE, method="emt")
expect_equal(w$qq[names(z$qq)],z$qq)
# Test ezt-j with figure 5
x61 <- bca(tt6, m6, cnames=cnames6, method="fzt")
x62 <- bca(tt6, m6, cnames=cnames6, method="ezt-m")
expect_equal(x61$qq[names(x62$qq)],x62$qq)
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.