R Under development (unstable) (2023-11-26 r85638 ucrt) -- "Unsuffered Consequences"
Copyright (C) 2023 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> 
> set.seed(290875)
> library("party")
Loading required package: grid
Loading required package: mvtnorm
Loading required package: modeltools
Loading required package: stats4
Loading required package: strucchange
Loading required package: zoo

Attaching package: 'zoo'

The following objects are masked from 'package:base':

    as.Date, as.Date.numeric

Loading required package: sandwich
> 
> ### get rid of the NAMESPACE
> attach(list2env(as.list(asNamespace("party"))))
The following objects are masked from package:party:

    cforest, cforest_classical, cforest_control, cforest_unbiased,
    conditionalTree, ctree, ctree_control, edge_simple,
    initVariableFrame, mob, mob_control, node_barplot, node_bivplot,
    node_boxplot, node_density, node_hist, node_inner,
    node_scatterplot, node_surv, node_terminal, nodes, party_intern,
    prettytree, proximity, ptrafo, response, reweight, sctest.mob,
    treeresponse, varimp, varimpAUC, where

> 
> ### 
> ###
> ###    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))
[1] TRUE
> isequal(eci@expectation, drop(weights %*% y / sum(weights)))
[1] TRUE
> 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)))
+ }
> 
> proc.time()
   user  system elapsed 
   1.79    0.45    2.18