Last updated on 2026-07-23 02:50:56 CEST.
| Flavor | Version | Tinstall | Tcheck | Ttotal | Status | Flags |
|---|---|---|---|---|---|---|
| r-devel-linux-x86_64-debian-clang | 2.9-13 | 15.12 | 514.41 | 529.53 | OK | |
| r-devel-linux-x86_64-debian-gcc | 2.9-13 | 11.82 | 309.37 | 321.19 | ERROR | |
| r-devel-linux-x86_64-fedora-clang | 2.9-13 | 27.00 | 843.54 | 870.54 | OK | |
| r-devel-linux-x86_64-fedora-gcc | 2.9-13 | 11.00 | 347.57 | 358.57 | OK | |
| r-devel-windows-x86_64 | 2.9-13 | 21.00 | 357.00 | 378.00 | OK | --no-vignettes |
| r-patched-linux-x86_64 | 2.9-13 | 17.60 | 504.14 | 521.74 | OK | |
| r-release-linux-x86_64 | 2.9-13 | 15.46 | 495.54 | 511.00 | OK | |
| r-release-macos-arm64 | 2.9-13 | 5.00 | 139.00 | 144.00 | OK | |
| r-release-macos-x86_64 | 2.9-13 | 13.00 | 681.00 | 694.00 | OK | |
| r-release-windows-x86_64 | 2.9-13 | 19.00 | 385.00 | 404.00 | OK | --no-vignettes |
| r-oldrel-macos-arm64 | 2.9-13 | OK | ||||
| r-oldrel-macos-x86_64 | 2.9-13 | 12.00 | 736.00 | 748.00 | OK | |
| r-oldrel-windows-x86_64 | 2.9-13 | 27.00 | 268.00 | 295.00 | OK | --no-vignettes |
Version: 2.9-13
Check: tests
Result: ERROR
Running ‘birds_Biometrics.R’ [10s/10s]
Comparing ‘birds_Biometrics.Rout’ to ‘birds_Biometrics.Rout.save’ ... OK
Running ‘bugfixes.R’ [38s/41s]
Running ‘regtest-baselearner.R’ [1s/2s]
Running ‘regtest-blackboost.R’ [42s/48s]
Comparing ‘regtest-blackboost.Rout’ to ‘regtest-blackboost.Rout.save’ ... OK
Running ‘regtest-family.R’ [14s/16s]
Comparing ‘regtest-family.Rout’ to ‘regtest-family.Rout.save’ ... OK
Running ‘regtest-gamboost.R’ [6s/6s]
Comparing ‘regtest-gamboost.Rout’ to ‘regtest-gamboost.Rout.save’ ... OK
Running ‘regtest-glmboost.R’ [9s/10s]
Comparing ‘regtest-glmboost.Rout’ to ‘regtest-glmboost.Rout.save’ ... OK
Running ‘regtest-hatmatrix.R’ [2s/3s]
Comparing ‘regtest-hatmatrix.Rout’ to ‘regtest-hatmatrix.Rout.save’ ... OK
Running ‘regtest-varimp.R’ [3s/4s]
Comparing ‘regtest-varimp.Rout’ to ‘regtest-varimp.Rout.save’ ... OK
Running the tests in ‘tests/bugfixes.R’ failed.
Complete output:
>
> options(digits = 3)
>
>
> .all.equal <- function(...) isTRUE(all.equal(..., check.environment = FALSE))
>
> require("mboost")
Loading required package: mboost
Loading required package: parallel
Loading required package: stabs
> require("Matrix")
Loading required package: Matrix
>
> set.seed(290875)
>
> ### predict did not return factor levels for blackboost models
> dummy <- data.frame(y = gl(2, 100), x = runif(200))
> pr <- predict(blackboost(y ~ x, data = dummy, family = Binomial()),
+ newdata = dummy, type = "class")
> print(is.factor(pr) && all(levels(pr) %in% levels(dummy$y)))
[1] TRUE
>
> ### predict for g{al}mboost.matrix did not work
> ctrl <- boost_control(mstop = 10)
> X <- cbind(int = 1, x = dummy$x)
> gb <- glmboost(x = X, y = dummy$y, family = Binomial(), center = FALSE,
+ control = ctrl)
> print(.all.equal(predict(gb), predict(gb, newdata = X)))
[1] TRUE
>
> if (FALSE) {
+ gb <- gamboost(x = X, y = dummy$y, family = Binomial(),
+ control = ctrl)
+ print(.all.equal(predict(gb), predict(gb, newdata = X)))
+ }
>
> ### predict with center = TRUE in glmboost.matrix() did not work
> gb <- glmboost(x = X, y = dummy$y, family = Binomial(),
+ control = ctrl, center=TRUE)
> p1 <- X %*% coef(gb)
NOTE: Coefficients from a Binomial model are half the size of coefficients
from a model fitted via glm(... , family = 'binomial').
See Warning section in ?coef.mboost
> print(max(abs(p1 - predict(gb, newdata = X))) < sqrt(.Machine$double.eps))
[1] TRUE
>
> ### blackboost _did_ touch the response, arg!
>
> data("bodyfat", package = "TH.data")
> ctrl <- boost_control(mstop = 500, nu = 0.01)
> bb <- blackboost(DEXfat ~ ., data = bodyfat, control = ctrl)
> n <- nrow(bodyfat)
> bs <- rmultinom(3, n, rep(1, n) / n)
> x <- seq(from = 10, to = 500, by = 10)
> cv <- cvrisk(bb, bs, grid = x, papply = lapply)
> ctrl$risk <- "oobag"
> tmp <- blackboost(DEXfat ~ ., data = bodyfat, control = ctrl,
+ weights = bs[,3])
>
> print(identical(max(abs(tmp$risk()[x + 1] / sum(bs[,3] == 0) - cv[3,])), 0))
[1] TRUE
>
> ### center = TRUE and cvrisk were broken; same issue with masking original data
>
> gb <- glmboost(DEXfat ~ ., data = bodyfat, center = TRUE)
> cv1 <- cvrisk(gb, folds = bs, papply = lapply)
> tmp <- glmboost(DEXfat ~ ., data = bodyfat, center = TRUE,
+ control = boost_control(risk = "oobag"),
+ weights = bs[,3])
> print(identical(max(tmp$risk()[attr(cv1, "mstop") + 1] / sum(bs[,3] == 0) - cv1[3,]), 0))
[1] TRUE
>
> ### same problem, just another check
>
> indep <- names(bodyfat)[names(bodyfat) != "DEXfat"]
> cbodyfat <- bodyfat
> cbodyfat[indep] <- lapply(cbodyfat[indep], function(x) x - mean(x))
> bffm <- DEXfat ~ age + waistcirc + hipcirc + elbowbreadth + kneebreadth +
+ anthro3a + anthro3b + anthro3c + anthro4
>
> bf_glm_1 <- glmboost(bffm, data = cbodyfat, center = FALSE)
> cv1 <- cvrisk(bf_glm_1, folds = bs, papply = lapply)
> bf_glm_2 <- glmboost(bffm, data = bodyfat, center = TRUE)
> cv2 <- cvrisk(bf_glm_2, folds = bs, papply = lapply)
>
> print(mstop(cv1) == mstop(cv2))
[1] TRUE
>
> if (FALSE){
+ ### dfbase=1 was not working correctly for ssp
+ ### spotted by Matthias Schmid <Matthias.Schmid@imbe.imed.uni-erlangen.de>
+ data("bodyfat", package = "TH.data")
+ ctrl <- boost_control(mstop = 100)
+ ### COMMENT: Not using ssp here but P-splines
+ ### Remove check!
+ ga <- gamboost(DEXfat ~ ., data = bodyfat, dfbase = 1, control = ctrl)
+ gl <- glmboost(DEXfat ~ ., data = bodyfat, center = TRUE, control = ctrl)
+ print(max(abs(predict(ga) - predict(gl))) < 1e-8)
+ AIC(gl)
+ }
>
> if (FALSE) {
+ ### prediction with matrices was broken for gamboost,
+ ### spotted by <Max.Kuhn@pfizer.com>
+ x <- matrix(rnorm(1000), ncol = 10)
+ colnames(x) <- 1:ncol(x)
+ y <- rnorm(100)
+ fit <- gamboost(x = x, y = y, control = boost_control(mstop = 10))
+ a <- predict(fit, newdata = x[1:10,])
+ }
>
> ### AIC for centered covariates didn't work
> y <- gl(2, 10)
> xn <- rnorm(20)
> xnm <- xn - mean(xn)
> gc <- glmboost(y ~ xn, center = TRUE,
+ family = Binomial())
> g <- glmboost(y ~ xnm, center = FALSE, family = Binomial())
> cgc <- coef(gc, off2int = TRUE)
NOTE: Coefficients from a Binomial model are half the size of coefficients
from a model fitted via glm(... , family = 'binomial').
See Warning section in ?coef.mboost
> cg <- coef(g, off2int = TRUE) - c(mean(xn) * coef(g)[2], 0)
NOTE: Coefficients from a Binomial model are half the size of coefficients
from a model fitted via glm(... , family = 'binomial').
See Warning section in ?coef.mboost
NOTE: Coefficients from a Binomial model are half the size of coefficients
from a model fitted via glm(... , family = 'binomial').
See Warning section in ?coef.mboost
> names(cgc) <- NULL
> names(cg) <- NULL
> print(.all.equal(cgc, cg))
[1] TRUE
> print(.all.equal(mstop(AIC(gc, "classical")),
+ mstop(AIC(g, "classical"))))
[1] TRUE
>
> ### fit ANCOVA models with centering
> n <- 50
> set.seed(290875)
> x <- gl(3, n)
> x1 <- sample(ordered(gl(3, n)))
> z <- rnorm(length(x))
> X <- model.matrix(~ x + z + x1)
> eff <- X %*% (1:ncol(X))
> y <- rnorm(length(x), mean = eff)
>
> ctr <- list(list(x = "contr.treatment"), list(x = "contr.sum"),
+ list(x = "contr.helmert"), list(x = "contr.SAS"))
> mstop <- 2000
> fm <- y ~ z:x + x + z:x1
>
> for (cc in ctr) {
+ modlm <- lm(fm, contrasts = cc)
+ modT <- glmboost(fm, contrasts.arg = cc,
+ center = TRUE)[mstop]
+ print(max(abs(coef(modlm) - coef(modT, off2int = TRUE)))
+ < .Machine$double.eps^(1/3))
+ print(max(abs(hatvalues(modlm) - hatvalues(modT))) < 0.01)
+ print(max(abs(predict(modlm) - predict(modT)))
+ < .Machine$double.eps^(1/3))
+ }
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
>
> y <- factor(rbinom(length(x), size = 1,
+ prob = plogis(eff / max(abs(eff)) * 3)))
> for (cc in ctr) {
+ modlm <- glm(fm, contrasts = cc,
+ family = binomial())
+ modT <- glmboost(fm, contrasts.arg = cc,
+ center = TRUE, family = Binomial())[mstop]
+ print(max(abs(coef(modlm) - coef(modT, off2int = TRUE) * 2))
+ < .Machine$double.eps^(1/3))
+ print(max(abs(predict(modlm) - predict(modT) * 2))
+ < .Machine$double.eps^(1/3))
+ }
NOTE: Coefficients from a Binomial model are half the size of coefficients
from a model fitted via glm(... , family = 'binomial').
See Warning section in ?coef.mboost
[1] TRUE
[1] TRUE
NOTE: Coefficients from a Binomial model are half the size of coefficients
from a model fitted via glm(... , family = 'binomial').
See Warning section in ?coef.mboost
[1] TRUE
[1] TRUE
NOTE: Coefficients from a Binomial model are half the size of coefficients
from a model fitted via glm(... , family = 'binomial').
See Warning section in ?coef.mboost
[1] TRUE
[1] TRUE
NOTE: Coefficients from a Binomial model are half the size of coefficients
from a model fitted via glm(... , family = 'binomial').
See Warning section in ?coef.mboost
[1] TRUE
[1] TRUE
>
>
> ### check gamboost with weights (use weighted some of residuals
> ### for variable selection)
> data("bodyfat", package = "TH.data")
>
> set.seed(290875)
> n <- nrow(bodyfat)
> w <- numeric(n)
> w <- rmultinom(1, n, rep(1, n) / n)[,1]
> ctrl <- boost_control(mstop = 20)
>
> mod1 <- glmboost(DEXfat ~ ., data = bodyfat, weights = w, center = FALSE)
> aic1 <- AIC(mod1, "corrected")
> attributes(aic1) <- NULL
>
> mod2 <- glmboost(DEXfat ~ ., data = bodyfat[rep(1:n, w),], center = FALSE)
> aic2 <- AIC(mod2, "corrected")
> attributes(aic2) <- NULL
>
> print(.all.equal(round(aic1, 3), round(aic2, 3)))
[1] TRUE
>
> mod1 <- gamboost(DEXfat ~ ., data = bodyfat, weights = w, con = ctrl)
> aic1 <- AIC(mod1, "corrected")
> attributes(aic1) <- NULL
>
> mod2 <- gamboost(DEXfat ~ ., data = bodyfat[rep(1:n, w),], con = ctrl)
> aic2 <- AIC(mod2, "corrected")
> attributes(aic2) <- NULL
>
> print(.all.equal(round(aic1, 1), round(aic2, 1)))
[1] TRUE
>
> mod1 <- blackboost(DEXfat ~ ., data = bodyfat, weights = w)
> mod2 <- blackboost(DEXfat ~ ., data = bodyfat[rep(1:n, w),])
>
> ratio <- mod1$risk() / mod2$risk()
> print(ratio[1] > 0.95 && ratio[2] < 1.05)
[1] TRUE
>
> if (FALSE){
+ ### df <= 2
+ ctrl$risk <- "oobag"
+ mod1 <- gamboost(DEXfat ~ ., data = bodyfat, weights = w, con = ctrl, base = "bss", dfbase = 2)
+ mod2 <- gamboost(DEXfat ~ ., data = bodyfat, weights = w, con = ctrl, base = "bbs", dfbase = 2)
+ mod3 <- gamboost(DEXfat ~ ., data = bodyfat, weights = w, con = ctrl, base = "bols")
+ print(max(abs(predict(mod1) - predict(mod2))) < sqrt(.Machine$double.eps))
+ print(max(abs(predict(mod1) - predict(mod3))) < sqrt(.Machine$double.eps))
+ }
>
> ### check predictions of zero-weight observations (via out-of-bag risk)
> mod1 <- gamboost(DEXfat ~ ., data = bodyfat, weights = w, con = ctrl, base = "bss")
Warning message:
In gamboost(DEXfat ~ ., data = bodyfat, weights = w, con = ctrl, :
bss and bns are deprecated, bbs is used instead
> mod2 <- gamboost(DEXfat ~ ., data = bodyfat, weights = w, con = ctrl, base = "bbs")
> print(abs(coef(lm(mod1$risk() ~ mod2$risk() - 1)) - 1) < 0.01)
mod2$risk()
TRUE
>
> ### not really a bug, a new feature; test fastp
> df <- data.frame(y = rnorm(100), x = runif(100), z = runif(100))
> eps <- sqrt(.Machine$double.eps)
> s <- seq(from = 1, to = 100, by = 3)
>
> x <- glmboost(y ~ ., data = df, center = FALSE)
> for (i in s)
+ print(max(abs(predict(x[i]) - predict(x[max(s)], agg = "cumsum")[,i])) < eps)
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
>
> x <- gamboost(y ~ ., data = df)
> for (i in s)
+ print(max(abs(predict(x[i]) - predict(x[max(s)], agg = "cumsum")[,i])) < eps)
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
>
> x <- blackboost(y ~ ., data = df)
> for (i in s)
+ print(max(abs(predict(x[i]) - predict(x[max(s)], agg = "cumsum")[,i])) < eps)
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
>
> ### make sure environment(formula) is used for evaluation
> if (require("partykit")) {
+ data("cars")
+ ctl <- boost_control(mstop = 100, trace = TRUE)
+ tctl <- ctree_control(teststat = "max", testtype = "Teststat",
+ mincrit = 0, maxdepth = 5, saveinfo = FALSE)
+ myfun <- function(cars, xx, zz){
+ mboost(dist ~ btree(speed, tree_controls = zz),
+ data = cars, control = xx)
+ }
+ try(mod <- myfun(cars, xx = ctl, zz = tctl))
+ }
Loading required package: partykit
Loading required package: grid
Loading required package: libcoin
Loading required package: mvtnorm
Attaching package: 'partykit'
The following object is masked from 'package:mboost':
varimp
[ 1] ...................................... -- risk: 9247
[ 41] ...................................... -- risk: 9006
[ 81] ..................
Final risk: 8977
>
> ### bbs with weights and expanded data
> x <- runif(100)
> y <- rnorm(length(x))
> knots <- seq(from = 0.1, to = 0.9, by = 0.1)
> w <- rmultinom(1, length(x), rep(1, length(x)) / length(x))[,1]
> iw <- rep(1:length(x), w)
>
> m1 <- bbs(x, knots = knots)$dpp(w)$fit(y)$model
> m2 <- bbs(x[iw], knots = knots)$dpp(rep(1, length(iw)))$fit(y[iw])$model
>
> print(max(abs(m1 - m2)) < sqrt(.Machine$double.eps))
[1] TRUE
>
> ### base learner handling
> print(max(abs(fitted(gamboost(DEXfat ~ age, data = bodyfat)) -
+ fitted(gamboost(DEXfat ~ bbs(age), data = bodyfat)))) <
+ sqrt(.Machine$double.eps))
[1] TRUE
>
> ### predict for matrix interface to glmboost
> x <- matrix(runif(1000), ncol = 10)
> y <- rowMeans(x) + rnorm(nrow(x))
> mod <- glmboost(x = x, y = y, center = FALSE)
> print(length(predict(mod, newdata = x[1:2,])) == 2)
[1] TRUE
> try(predict(mod, newdata = as.data.frame(x[1:2,])))
Error in object$newX(newdata) :
'newdata' is not a matrix with the same variables as 'x'
>
>
> ### predict for varying coefficient models with categorical z
> set.seed(1907)
> x <- rnorm(100)
> z <- gl(2,50)
> y <- rnorm(100, sd = 0.1)
> data <- data.frame(y=y, x=x, z=z)
>
> model <- gamboost(y ~ bols(x, by=z), data = data)
> print(!is.na(predict(model,data[1,-1])))
[,1]
[1,] TRUE
>
> model <- gamboost(y ~ bbs(x, by=z), data = data)
> print(!is.na(predict(model,data[1,-1])))
[,1]
[1,] TRUE
>
> x <- as.factor(sample(1:10, 100, replace=TRUE))
> data <- data.frame(y=y, x=x, z=z)
> model <- gamboost(y ~ brandom(x, by=z), data = data)
> print(!is.na(predict(model,data[1,-1])))
[,1]
[1,] TRUE
>
> x1 <- rnorm(100)
> x2 <- rnorm(100)
> data <- data.frame(y=y, x1=x1, x2=x2, z=z)
> model <- gamboost(y ~ bspatial(x1,x2, by=z), data = data)
> print(!is.na(predict(model,data[1,-1])))
[,1]
[1,] TRUE
>
> ### bols with intercept = FALSE for categorical covariates was broken
> x <- gl(2, 50)
> y <- c(rnorm(50, mean = -1), rnorm(50, mean = 1))
> print(length(coef(gamboost(y ~ bols(x, intercept=FALSE)))) == 1)
[1] TRUE
>
> # check also for conntinuous x
> x <- rnorm(100)
> y <- c(rnorm(100, mean = 1 * x))
> print(length(coef(gamboost(y ~ bols(x, intercept=FALSE)))) == 1)
[1] TRUE
>
> ### check interface of coef
> set.seed(1907)
> x1 <- rnorm(100)
> int <- rep(1, 100)
> y <- 3 * x1 + rnorm(100, sd=0.1)
> dummy <- data.frame(y = y, int = int, x1 = x1)
>
> gbm <- gamboost(y ~ bols(int, intercept=FALSE) + bols(x1, intercept=FALSE) +
+ bbs(x1, center=TRUE, df=1), data = dummy)
>
> ### check prediction if intercept=FALSE
> gbm <- gamboost(y ~ bols(x1, intercept=FALSE), data = dummy)
> print(!is.na(predict(gbm)) &
+ max(abs(predict(gbm) - fitted(gbm))) < sqrt(.Machine$double.eps))
[,1]
[1,] TRUE
[2,] TRUE
[3,] TRUE
[4,] TRUE
[5,] TRUE
[6,] TRUE
[7,] TRUE
[8,] TRUE
[9,] TRUE
[10,] TRUE
[11,] TRUE
[12,] TRUE
[13,] TRUE
[14,] TRUE
[15,] TRUE
[16,] TRUE
[17,] TRUE
[18,] TRUE
[19,] TRUE
[20,] TRUE
[21,] TRUE
[22,] TRUE
[23,] TRUE
[24,] TRUE
[25,] TRUE
[26,] TRUE
[27,] TRUE
[28,] TRUE
[29,] TRUE
[30,] TRUE
[31,] TRUE
[32,] TRUE
[33,] TRUE
[34,] TRUE
[35,] TRUE
[36,] TRUE
[37,] TRUE
[38,] TRUE
[39,] TRUE
[40,] TRUE
[41,] TRUE
[42,] TRUE
[43,] TRUE
[44,] TRUE
[45,] TRUE
[46,] TRUE
[47,] TRUE
[48,] TRUE
[49,] TRUE
[50,] TRUE
[51,] TRUE
[52,] TRUE
[53,] TRUE
[54,] TRUE
[55,] TRUE
[56,] TRUE
[57,] TRUE
[58,] TRUE
[59,] TRUE
[60,] TRUE
[61,] TRUE
[62,] TRUE
[63,] TRUE
[64,] TRUE
[65,] TRUE
[66,] TRUE
[67,] TRUE
[68,] TRUE
[69,] TRUE
[70,] TRUE
[71,] TRUE
[72,] TRUE
[73,] TRUE
[74,] TRUE
[75,] TRUE
[76,] TRUE
[77,] TRUE
[78,] TRUE
[79,] TRUE
[80,] TRUE
[81,] TRUE
[82,] TRUE
[83,] TRUE
[84,] TRUE
[85,] TRUE
[86,] TRUE
[87,] TRUE
[88,] TRUE
[89,] TRUE
[90,] TRUE
[91,] TRUE
[92,] TRUE
[93,] TRUE
[94,] TRUE
[95,] TRUE
[96,] TRUE
[97,] TRUE
[98,] TRUE
[99,] TRUE
[100,] TRUE
>
> ### check coef.glmboost
> set.seed(1907)
> x1 <- rnorm(100)
> x2 <- rnorm(100)
> y <- rnorm(100, mean= 3 * x1,sd=0.01)
> linMod <- glmboost(y ~ x1 + x2, center = FALSE)
> print(length(coef(linMod)) == 2)
[1] TRUE
>
> ### automated offset computation in Family
> x <- rnorm(100)
> y <- rnorm(100)
> w <- drop(rmultinom(1, 100, rep(1 / 100, 100)))
>
> G <- Gaussian()
> fm <- Family(ngradient = G@ngradient, risk = G@risk)
>
> m1 <- glmboost(y ~ x, family = G, center = FALSE)
> m2 <- glmboost(y ~ x, family = fm, center = FALSE)
> print(.all.equal(coef(m1), coef(m2)))
[1] TRUE
>
> ### formula evaluation
> f <- function() {
+
+ x <- rnorm(100)
+ y <- rnorm(100)
+ list(mboost(y ~ bbs(x)),
+ gamboost(y ~ x),
+ glmboost(y ~ x, center = FALSE),
+ blackboost(y ~ x))
+ }
> tmp <- f()
>
> ### both loss and risk given, spotted by
> ### Fabian Scheipl <fabian.scheipl@stat.uni-muenchen.de>
> print(extends(class(Family(ngradient = function(y, f) y,
+ loss = function(y, w) sum(y),
+ risk = function(y, f, w) sum(y))),
+ "boost_family"))
[1] TRUE
>
> ### check coef with aggregate = "cumsum"
> mod <- glmboost(DEXfat ~ ., data = bodyfat, center = FALSE)
>
> print(max(abs(sapply(coef(mod, aggregate="cumsum"), function(x) x[,100])
+ - coef(mod))) < sqrt(.Machine$double.eps))
[1] TRUE
>
> ### get_index() was broken for factors
> ### (spotted by Juliane Schaefer <JSchaefer _at_ uhbs.ch>)
> y <- factor(c(2, 1, 1, 2, 2, 2, 1, 1, 2, 2), levels = 1:2, labels = c("N", "S"))
> x <- factor(c(2, 1, 2, 2, 2, 1, 1, 1, 2, 2), levels = 1:2,
+ labels = c("No", "Yes"))
> data <- data.frame(y,x)
> m1 <- glm(y ~ x, data = data, family = binomial())
> m2 <- glmboost(y ~ x, data = data, family = Binomial(),
+ control = boost_control(mstop = 2000), center = FALSE)
> m3 <- gamboost(y ~ bols(x), data = data, family = Binomial(),
+ control = boost_control(mstop = 1000))
> cf1 <- coef(m1)
> a <- coef(m2); a[1] <- a[1] + m2$offset;
NOTE: Coefficients from a Binomial model are half the size of coefficients
from a model fitted via glm(... , family = 'binomial').
See Warning section in ?coef.mboost
> cf2 <- as.vector(a) * 2
> b <- coef(m3); b[[1]][1] <- b[[1]][1] + m3$offset;
> cf3 <- b[[1]] * 2
>
> print(max(abs(cf1 - cf2)) < sqrt(.Machine$double.eps))
[1] TRUE
> print(max(abs(cf1 - cf3)) < sqrt(.Machine$double.eps))
[1] TRUE
> print(max(abs(predict(m2) - predict(m3))) < sqrt(.Machine$double.eps))
[1] TRUE
>
> ### bug in setting contrasts correctly
> z <- as.ordered(gl(3, 10))
> BL <- bols(z, contrasts.arg = "contr.treatment")$dpp
> print(attr(get("X", envir = environment(BL)), "contrasts")$z == "contr.treatment")
[1] TRUE
>
> ### check dimensions
> try(glmboost(x = matrix(1:10, nrow = 5), y = rnorm(4)))
Error in glmboost.matrix(x = matrix(1:10, nrow = 5), y = rnorm(4)) :
dimensions of 'x' and 'y' do not match
>
> ### (slight) abuse of bolscw
> X <- runif(1000)
> X <- matrix(X, nrow = 100)
> y <- rnorm(100)
> glmboost(x = X, y = y)
Generalized Linear Models Fitted via Gradient Boosting
Call:
glmboost.matrix(x = X, y = y)
Squared Error (Regression)
Loss function: (y - f)^2
Number of boosting iterations: mstop = 100
Step size: 0.1
Offset: -0.0242
Coefficients:
V1 V2 V3 V4 V5 V6 V7 V8 V9
-0.2433 -0.0787 0.3093 -0.1547 -0.4141 -0.0611 -0.2597 -0.7462 0.6370
attr(,"offset")
[1] -0.0242
Warning message:
In glmboost.matrix(x = X, y = y) :
model with centered covariates does not contain intercept
> b <- list(mboost:::bolscw(X))
> mboost_fit(blg = b, response = y)
Model-based Boosting
Squared Error (Regression)
Loss function: (y - f)^2
Number of boosting iterations: mstop = 100
Step size: 0.1
Offset: -0.0242
Number of baselearners: 1
> z <- rnorm(100)
> b <- list(b1 = mboost:::bolscw(X), b2 = bbs(z))
> mboost_fit(blg = b, response = y)
Model-based Boosting
Squared Error (Regression)
Loss function: (y - f)^2
Number of boosting iterations: mstop = 100
Step size: 0.1
Offset: -0.0242
Number of baselearners: 2
> mod <- mboost_fit(blg = b, response = y)
> cf <- coef(mod, which = 1)[[1]]
> print(length(cf) == ncol(X))
[1] TRUE
>
>
> ### check interface of buser
> ### (K was fetched from global environment)
> set.seed(1907)
> x <- rnorm(100)
> y <- rnorm(100, mean = x^2, sd = 0.1)
> mod1 <- gamboost(y ~ bbs(x))
> X1 <- extract(bbs(x))
> K1 <- extract(bbs(x), "penalty")
> mod2 <- gamboost(y ~ buser(X1, K1))
> print(max(abs(predict(mod1) - predict(mod2))) < sqrt(.Machine$double.eps))
[1] TRUE
>
>
> ### check if mysolve works correctly
> set.seed(1907)
> X <- matrix(runif(1000), ncol = 10)
> XM <- Matrix(X)
> y <- rnorm(nrow(X))
> # use interface for dense matrices from package Matrix
> f1 <- fitted(gamboost(y ~ bols(XM)))
> # use interface for matrices of class "matrix"
> f2 <- fitted(gamboost(y ~ bols(X)))
> print(max(abs(f1 - f2)) < sqrt(.Machine$double.eps))
[1] TRUE
> ## Now same with sparse matrix
> X[X < .9] <- 0
> XM <- Matrix(X)
> # use interface for sparse matrices from package Matrix
> f1 <- fitted(gamboost(y ~ bols(XM)))
> # use interface for matrices of class "matrix"
> f2 <- fitted(gamboost(y ~ bols(X)))
> print(max(abs(f1 - f2)) < sqrt(.Machine$double.eps))
[1] TRUE
>
> ### check if bmrf works correctly
> ## (if not all locations are observed)
> if (require("BayesX")) {
+ germany <- read.bnd(system.file("examples/germany.bnd", package="BayesX"))
+ districts <- attr(germany, "regions")
+ set.seed(1907)
+ regions <- factor(sample(districts, 400, replace = TRUE))
+ B <- bmrf(regions, bnd = germany)
+ X <- extract(B)
+ K <- extract(B, what = "pen")
+ Xs <- colSums(as.matrix(X))
+ names(Xs) <- rownames(K)
+ print(all(Xs[Xs > 0] == table(regions)[names(Xs[Xs > 0])]))
+
+ ## check against old, slower code:
+ Xold <- matrix(0, nrow = length(regions), ncol = ncol(K))
+ for (i in 1:length(regions))
+ Xold[i, which(districts == regions[i])] <- 1
+ print(all(X == Xold))
+ }
Loading required package: BayesX
Loading required package: shapefiles
Loading required package: foreign
Attaching package: 'shapefiles'
The following objects are masked from 'package:foreign':
read.dbf, write.dbf
Read 8852 records
Note: map consists of 310 polygons
Note: map consists of 309 regions
Reading map ... finished
Start neighbor search ...
progress: 50%
progress: 100%
Neighbor search finished.
[1] TRUE
[1] TRUE
>
> ## check handling of missing values
> y <- yNa <- rnorm(100)
> x1 <- rnorm(100)
> x2 <- rnorm(100)
> z1 <- as.factor(sample(1:10, 100, replace = TRUE))
>
> yNa[1] <- NA
> coef(mboost(yNa ~ x1))
$`bbs(x1)`
1 2 3 4 5 6 7 8 9 10
-0.3320 -0.2530 -0.1682 -0.0573 0.0583 0.1448 0.1618 0.0766 -0.0863 -0.2359
11 12 13 14 15 16 17 18 19 20
-0.3031 -0.2786 -0.1788 -0.0553 0.0593 0.1709 0.2980 0.3981 0.4216 0.3843
21 22 23 24
0.3296 0.2811 0.2355 0.1901
attr(,"offset")
[1] 0.086
Warning message:
In mboost_fit(bl, response = response, weights = weights, offset = offset, :*** buffer overflow detected ***: terminated
Aborted
Running the tests in ‘tests/regtest-baselearner.R’ failed.
Complete output:
>
> options(digits = 3)
>
> tol2 <- .Machine$double.eps^(1/3)
>
> .all.equal <- function(...) isTRUE(all.equal(..., check.environment = FALSE))
>
> library("mboost")
Loading required package: parallel
Loading required package: stabs
> attach(asNamespace("mboost"), warn.conflicts = FALSE)
> library("MASS")
> library("Matrix")
>
> set.seed(290875)
>
> ### dgp
> n <- 20000
> xn <- round(runif(n), 3)
> xn[sample(1:n)[1:(n / 100)]] <- NA
> xf <- gl(4, n / 4)
> xf[sample(1:n)[1:(n / 100)]] <- NA
> z1 <- sample(gl(2, n / 2))
> z1[sample(1:n)[1:(n / 100)]] <- NA
> z2 <- round(runif(n), 3)
> z2[sample(1:n)[1:(n / 100)]] <- NA
> w <- rpois(n, lambda = 2)
> y <- 2 * xn + rnorm(n)
> y[is.na(y)] <- rnorm(sum(is.na(y)))
>
> testfun <- function(m1, m2) {
+ ret <- c(max(abs(coef(m1) - coef(m2))),
+ max(abs(fitted(m1) - fitted(m2)()), na.rm = TRUE))
+ if (any(ret > sqrt(.Machine$double.eps)))
+ return(ret)
+ }
>
> ### numeric x with intercept
> m1 <- lm(y ~ xn, weights = w, na.action = na.exclude)
> m2 <- fit(dpp(bols(xn), w), y)
Warning message:
In bols(xn) :*** buffer overflow detected ***: terminated
Aborted
Flavor: r-devel-linux-x86_64-debian-gcc