Switch to side-by-side view

--- a
+++ b/partyMod/tests/LinearStatistic-regtest.R
@@ -0,0 +1,120 @@
+
+set.seed(290875)
+library("party")
+
+### get rid of the NAMESPACE
+attach(asNamespace("party"))
+
+### 
+###
+###    Regression tests for linear statistics, expectations and covariances
+###    
+###    functions defined in file `./src/LinearStatistics.c'    
+
+### tests for function C_LinearStatistic
+### Linear Statistics
+x = matrix(c(rep.int(1,4), rep.int(0,6)), ncol = 1)
+y = matrix(1:10, ncol = 1)
+weights = rep(1, 10)
+linstat = LinearStatistic(x, y, weights)
+stopifnot(isequal(linstat, sum(1:4)))
+
+weights[1] = 0
+linstat = LinearStatistic(x, y, weights) 
+stopifnot(isequal(linstat, sum(2:4)))
+
+xf <- gl(3, 10)
+yf <- gl(3, 10)[sample(1:30)]
+x <- sapply(levels(xf), function(l) as.numeric(xf == l))
+colnames(x) <- NULL
+y <- sapply(levels(yf), function(l) as.numeric(yf == l))
+colnames(y) <- NULL
+weights <- sample(1:30)
+linstat <- LinearStatistic(x, y, weights) 
+stopifnot(isequal(linstat, as.vector(t(x) %*% diag(weights) %*% y)))
+
+xf <- factor(cut(rnorm(6000), breaks = c(-Inf, -2, 0.5, Inf)))
+x <- sapply(levels(xf), function(l) as.numeric(xf == l))
+yf <- factor(cut(rnorm(6000), breaks = c(-Inf, -0.5, 1.5, Inf)))
+y <- sapply(levels(yf), function(l) as.numeric(yf == l))
+weights <- rep(1, nrow(x))
+colnames(x) <- NULL
+colnames(y) <- NULL
+weights <- rep(1, 6000)
+linstat <- LinearStatistic(x, y, weights)
+stopifnot(isequal(as.vector(table(xf, yf)), linstat))
+stopifnot(isequal(as.vector(t(x)%*%y), linstat))
+
+
+### tests for function C_ExpectCovarInfluence
+eci <- ExpectCovarInfluence(y, weights)
+isequal(eci@sumweights, sum(weights))
+isequal(eci@expectation, drop(weights %*% y / sum(weights)))
+ys <- t(t(y) - eci@expectation)
+stopifnot(isequal(eci@covariance, (t(ys) %*% (weights * ys)) /
+                  sum(weights)))
+
+### tests for function C_ExpectCovarLinearStatistic
+### Conditional Expectation and Variance (via Kruskal-Wallis statistic)
+
+### case 1: p > 1, q = 1
+group <- gl(3, 5)
+x <- sapply(levels(group), function(l) as.numeric(group == l))
+y <- matrix(1:15, ncol = 1)
+weights <- rep(1, 15)
+
+linstat <- LinearStatistic(x, y, weights)
+expcov <- ExpectCovarLinearStatistic(x, y, weights)
+KW <- quadformTestStatistic(linstat, expcov@expectation, expcov@covariance)
+kts <- kruskal.test(y ~ group)$statistic
+stopifnot(isequal(KW, kts))
+
+### case 2: p = 1, q > 1
+linstat <- LinearStatistic(y, x, weights)
+expcov <- ExpectCovarLinearStatistic(y, x, weights)
+KW <- quadformTestStatistic(linstat, expcov@expectation, expcov@covariance)
+kts <- kruskal.test(y ~ group)$statistic
+stopifnot(isequal(KW, kts))
+
+### case 3: p = 1, q = 1
+x <- x[,1,drop = FALSE]
+linstat <- LinearStatistic(x, y, weights)
+expcov <- ExpectCovarLinearStatistic(x, y, weights)
+KW <- quadformTestStatistic(linstat, expcov@expectation, expcov@covariance)
+kts <- kruskal.test(y ~ as.factor(x))$statistic
+stopifnot(isequal(KW, kts))
+
+### case 4: p > 1, q > 1 via chisq.test
+n <- 900
+xf <- gl(3, n / 3)
+yf <- gl(3, n / 3)[sample(1:n)]
+x <- sapply(levels(xf), function(l) as.numeric(xf == l))
+colnames(x) <- NULL
+y <- sapply(levels(yf), function(l) as.numeric(yf == l))
+colnames(y) <- NULL
+weights <- rep(1, n)
+linstat <- LinearStatistic(x, y, weights)
+expcov <- ExpectCovarLinearStatistic(x, y, weights)
+chi <- quadformTestStatistic(linstat, expcov@expectation, expcov@covariance)
+chis <- chisq.test(table(xf, yf))$statistic
+stopifnot(isequal(round(chi, 1), round(chis, 1)))
+
+### tests for function C_PermutedLinearStatistic
+### Linear Statistics with permuted indices
+x <- matrix(rnorm(100), ncol = 2)
+y <- matrix(rnorm(100), ncol = 2)
+weights <- rep(1, 50)
+indx <- 1:50
+perm <- 1:50
+stopifnot(isequal(LinearStatistic(x, y, weights), 
+                  PermutedLinearStatistic(x, y, indx, perm)))
+x <- matrix(1:10000, ncol = 2)
+y <- matrix(1:10000, ncol = 2)
+
+for (i in 1:100) {
+  indx <- sample(1:ncol(y), replace = TRUE)
+  perm <- sample(1:ncol(y), replace = TRUE)
+
+  stopifnot(isequal(as.vector(t(x[indx,]) %*% y[perm, ]),
+                    PermutedLinearStatistic(x, y, indx, perm)))
+}