R Under development (unstable) (2024-08-16 r87026 ucrt) -- "Unsuffered Consequences"
Copyright (C) 2024 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.

> suppressWarnings(RNGversion("3.5.2"))
> 
> library("partykit")
Loading required package: grid
Loading required package: libcoin
Loading required package: mvtnorm
> 
> 
> ## artificial data ---------------------------------------------------------------------------------
> set.seed(0)
> d <- data.frame(x = seq(-1, 1, length.out = 1000), z = factor(rep(0:1, 500)))
> d$y <- 0 + 1 * d$x + rnorm(nrow(d))
> d$w <- rep(1:4, nrow(d)/4)
> dd <- d[rep(1:nrow(d), d$w), ]
> 
> 
> ## convenience function: likelihood ratio test -----------------------------------------------------
> lrtest <- function(data, ...) {
+   lr <- -2 * (logLik(lm(y ~ x, data = data, ...)) - logLik(lm(y ~ x * z, data = data, ...)))
+   matrix(
+     c(lr, pchisq(lr, df = 2, lower.tail = FALSE)),
+     dimnames = list(c("statistic", "p.value"), "z")
+   )
+ }
> 
> 
> ## lm: case weights --------------------------------------------------------------------------------
> 
> ## weighted and explicitly expanded data should match exactly
> lm1 <- lmtree(y ~ x | z, data = d, weights = w, maxdepth = 2)
> lm2 <- lmtree(y ~ x | z, data = dd, maxdepth = 2)
> all.equal(sctest.modelparty(lm1), sctest.modelparty(lm2))
[1] TRUE
> 
> ## LR test should be similar (albeit not identical)
> all.equal(sctest.modelparty(lm1), lrtest(dd), tol = 0.05)
[1] TRUE
> 
> 
> ## lm: proportionality weights ---------------------------------------------------------------------
> 
> ## LR test should be similar
> lm3 <- lmtree(y ~ x | z, data = d, weights = w, maxdepth = 2, caseweights = FALSE)
> all.equal(sctest.modelparty(lm3), lrtest(d, weights = d$w), tol = 0.05)
[1] TRUE
> 
> ## constant factor should not change results
> lm3x <- lmtree(y ~ x | z, data = d, weights = 2 * w, maxdepth = 2, caseweights = FALSE)
> all.equal(sctest.modelparty(lm3), sctest.modelparty(lm3x))
[1] TRUE
> 
> 
> ## glm: case weights -------------------------------------------------------------------------------
> 
> ## for glm different vcov are available
> glm1o <- glmtree(y ~ x | z, data = d, weights = w, maxdepth = 2, vcov = "opg")
> glm2o <- glmtree(y ~ x | z, data = dd, maxdepth = 2, vcov = "opg")
> all.equal(sctest.modelparty(glm1o), sctest.modelparty(glm1o))
[1] TRUE
> 
> glm1i <- glmtree(y ~ x | z, data = d, weights = w, maxdepth = 2, vcov = "info")
> glm2i <- glmtree(y ~ x | z, data = dd, maxdepth = 2, vcov = "info")
> all.equal(sctest.modelparty(glm1i), sctest.modelparty(glm2i))
[1] TRUE
> 
> glm1s <- glmtree(y ~ x | z, data = d, weights = w, maxdepth = 2, vcov = "sandwich")
> glm2s <- glmtree(y ~ x | z, data = dd, maxdepth = 2, vcov = "sandwich")
> all.equal(sctest.modelparty(glm1s), sctest.modelparty(glm2s))
[1] TRUE
> 
> ## different vcov should yield similar (albeit not identical) statistics
> all.equal(sctest.modelparty(glm1o), sctest.modelparty(glm1i), tol = 0.05)
[1] TRUE
> all.equal(sctest.modelparty(glm1o), sctest.modelparty(glm1s), tol = 0.05)
[1] TRUE
> 
> ## LR test should be similar
> all.equal(sctest.modelparty(glm1o), lrtest(dd), tol = 0.05)
[1] TRUE
> 
> 
> ## glm: proportionality weights --------------------------------------------------------------------
> 
> ## different test versions should be similar
> glmFo <- glmtree(y ~ x | z, data = d, weights = w, maxdepth = 2, caseweights = FALSE, vcov = "opg")
> glmFi <- glmtree(y ~ x | z, data = d, weights = w, maxdepth = 2, caseweights = FALSE, vcov = "info")
> glmFs <- glmtree(y ~ x | z, data = d, weights = w, maxdepth = 2, caseweights = FALSE, vcov = "sandwich")
> 
> all.equal(sctest.modelparty(glmFo), sctest.modelparty(glmFi), tol = 0.05)
[1] TRUE
> all.equal(sctest.modelparty(glmFo), sctest.modelparty(glmFs), tol = 0.05)
[1] TRUE
> all.equal(sctest.modelparty(glmFo), lrtest(d, weights = d$w), tol = 0.05)
[1] TRUE
> 
> ## constant factor should not change results
> glmFxo <- glmtree(y ~ x | z, data = d, weights = 2 * w, maxdepth = 2, caseweights = FALSE, vcov = "opg")
> glmFxi <- glmtree(y ~ x | z, data = d, weights = 2 * w, maxdepth = 2, caseweights = FALSE, vcov = "info")
> glmFxs <- glmtree(y ~ x | z, data = d, weights = 2 * w, maxdepth = 2, caseweights = FALSE, vcov = "sandwich")
> 
> all.equal(sctest.modelparty(glmFo), sctest.modelparty(glmFxo))
[1] TRUE
> all.equal(sctest.modelparty(glmFi), sctest.modelparty(glmFxi))
[1] TRUE
> all.equal(sctest.modelparty(glmFs), sctest.modelparty(glmFxs))
[1] TRUE
> 
> proc.time()
   user  system elapsed 
   1.17    0.15    1.31