R Under development (unstable) (2014-06-29 r66051) -- "Unsuffered Consequences"

Copyright (C) 2014 The R Foundation for Statistical Computing

Platform: x86_64-unknown-linux-gnu (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.

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: zoo

Attaching package: 'zoo'

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

    as.Date, as.Date.numeric

Loading required package: sandwich

Loading required package: strucchange

Loading required package: modeltools

Loading required package: stats4

> 

> ### get rid of the NAMESPACE

> attach(asNamespace("party"))

The following objects are masked from package:party:

    cforest, cforest_classical, cforest_control, cforest_unbiased,

    conditionalTree, ctree, ctree_control, ctree_memory, edge_simple,

    mob, mob_control, node_barplot, node_bivplot, node_boxplot,

    node_density, node_hist, node_inner, node_scatterplot, node_surv,

    node_terminal, proximity, ptrafo, reweight, sctest.mob, varimp,

    varimpAUC

> 

> ### 

> ###

> ###    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 

  0.776   0.020   0.793