
R version 4.6.1 (2026-06-24) -- "Happy Hop"
Copyright (C) 2026 The R Foundation for Statistical Computing
Platform: x86_64-pc-linux-gnu

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.

> 
> 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("survival")
Loading required package: survival
> 
> set.seed(290875)
> 
> ### for boosting hat matrix checks
> fm <- Gaussian()
> fm@offset <- function(y, w) 0
> 
> ### a simple two-dimensional example from `gamboost.Rd'
> data("cars")
> cars.gb <- gamboost(dist ~ speed, data = cars, df = 4, family = fm,
+                     control = boost_control(mstop = 50))
> cars.gb

	 Model-based Boosting

Call:
gamboost(formula = dist ~ speed, data = cars, family = fm, control = boost_control(mstop = 50),     dfbase = 4)


	 Squared Error (Regression) 

Loss function: (y - f)^2 
 

Number of boosting iterations: mstop = 50 
Step size:  0.1 
Offset:  0 
Number of baselearners:  1 

> aic <- AIC(cars.gb, method = "corrected")
> aic
[1] 6.59
Optimal number of boosting iterations: 37 
Degrees of freedom (for mstop = 37): 4.37 
> 
> aic2 <- AIC(cars.gb, method = "corrected", df = "actset")
Warning message:
In AIC.mboost(cars.gb, method = "corrected", df = "actset") :
  df = "actset" can only be used with 'glmboost' models. df = "trace" is used instead.
> print(.all.equal(aic, aic2))
[1] TRUE
> 
> ht <- hatvalues(cars.gb)
> 
> ## extract residual
> print(.all.equal(resid(cars.gb), cars.gb$resid()))
[1] TRUE
> par(mfrow = c(1, 2))
> plot(cars$speed, resid(cars.gb[0]))
> cars$resid <- resid(cars.gb)
> lines(cars$speed, predict(loess(resid ~ speed, cars)), col = "red")
> plot(cars$speed, resid(cars.gb[50]))
> cars$resid <- resid(cars.gb)
> lines(cars$speed, predict(loess(resid ~ speed, cars)), col = "red")
> 
> ## check return = FALSE
> print(is.null(cars.gb[10, return = FALSE]))
[1] TRUE
> print(mstop(cars.gb) == 10)
[1] TRUE
> 
> ### plot fit
> plot(dist ~ speed, data = cars)
> lines(cars$speed, predict(cars.gb[mstop(AIC(cars.gb))]), col = "red")
> lines(cars$speed, predict(smooth.spline(cars$speed, cars$dist), cars$speed)$y,
+       col = "green")
> 
> ## print model summary
> summary(cars.gb)

	 Model-based Boosting

Call:
gamboost(formula = dist ~ speed, data = cars, family = fm, control = boost_control(mstop = 50),     dfbase = 4)


	 Squared Error (Regression) 

Loss function: (y - f)^2 
 

Number of boosting iterations: mstop = 10 
Step size:  0.1 
Offset:  0 
Number of baselearners:  1 

Selection frequencies:
bbs(speed, df = dfbase) 
                      1 

> 
> #### check boosting hat matrix and subsetting / predict
> print(isTRUE(.all.equal(drop(attr(ht, "hatmatrix") %*% cars$dist),
+                            as.vector(predict(cars.gb[50])))))
[1] TRUE
> ht25 <- hatvalues(cars.gb[25])
> print(isTRUE(.all.equal(drop(attr(ht25, "hatmatrix") %*% cars$dist),
+                            as.vector(predict(cars.gb[25])))))
[1] TRUE
> print(isTRUE(.all.equal(drop(attr(ht25, "hatmatrix") %*% cars$dist),
+                            as.vector(fitted(cars.gb[25])))))
[1] TRUE
> 
> ### check boosting hat matrix with multiple independent variables
> ### and weights
> data("bodyfat", package = "TH.data")
> bffm <- DEXfat ~ age + waistcirc + hipcirc + elbowbreadth + kneebreadth +
+       anthro3a + anthro3b + anthro3c + anthro4
> indep <- names(bodyfat)[names(bodyfat) != "DEXfat"]
> bodyfat[indep] <- lapply(bodyfat[indep], function(x) x - mean(x))
> bf_gam <- gamboost(bffm, data = bodyfat, control = boost_control(mstop = 10),
+                    weights = runif(nrow(bodyfat)) * 10)
> ### aic <- AIC(bf_gam)
> ht <- hatvalues(bf_gam)
> 
> off <- bf_gam$offset
> u <- bf_gam$ustart
> 
> print(isTRUE(.all.equal(drop(attr(ht, "hatmatrix") %*% u + off),
+                            as.vector(predict(bf_gam)))))
[1] TRUE
> print(isTRUE(.all.equal(drop(attr(ht, "hatmatrix") %*% u + off),
+                            as.vector(fitted(bf_gam)))))
[1] TRUE
> 
> 
> ### compare `gamboost' with `lm' in cases where this is actually possible
> set.seed(290875)
> x <- matrix(runif(1000) * 10, ncol = 10)
> xf <- gl(4, nrow(x)/4)
> 
> ### OK, we need to allow for some small differences (larger mstop values
> ### would fix this)
> stopin <- function(x, y) print(max(abs(x - y)) < 0.1)
> 
> ### univariate linear model
> df <- data.frame(y = 3*x[,2], x = x)
> ga <- gamboost(y ~ x.2, data = df,
+                control = boost_control(mstop = 500, nu = 1))
> stopin(fitted(lm(y ~ x.2 - 1, data = df)), fitted(ga))
[1] TRUE
> 
> ### univariate model involving sin transformation
> df <- data.frame(y = sin(x[,1]), x = x)
> ga <- gamboost(y ~ x.1, data = df,
+                control = boost_control(mstop = 500, nu = 1))
> stopin(fitted(lm(y ~ sin(x.1) - 1, data = df)), fitted(ga))
[1] TRUE
> 
> ### bivariate model: linear and sin
> df <- data.frame(y = sin(x[,1]) + 3*x[,2], x = x)
> ga <- gamboost(y ~ x.1 + x.2, data = df,
+                control = boost_control(mstop = 500, nu = 1))
> stopin(fitted(lm(y ~ sin(x.1) + x.2 - 1, data = df)), fitted(ga))
[1] TRUE
> ga <- gamboost(y ~ x.1 + bols(x.2), data = df,
+                control = boost_control(mstop = 500, nu = 1))
> stopin(fitted(lm(y ~ sin(x.1) + x.2 - 1, data = df)), fitted(ga))
[1] TRUE
> 
> ### ANCOVA model
> df <- data.frame(y = 3 * x[,2] + (1:4)[xf], x = x)
> ga <- gamboost(y ~ xf + x.2, data = df,
+                control = boost_control(mstop = 500, nu = 1))
Warning message:
In bbs(as.data.frame(list(...)), df = dfbase) :
  cannot compute 'bbs' for non-numeric variables; used 'bols' instead.
> stopin(fitted(lm(y ~ xf + x.2 - 1, data = df)), fitted(ga))
[1] TRUE
> ga <- gamboost(y ~ xf + sin(x.1) + x.2, data = df,
+                control = boost_control(mstop = 500, nu = 1))
Warning message:
In bbs(as.data.frame(list(...)), df = dfbase) :
  cannot compute 'bbs' for non-numeric variables; used 'bols' instead.
> stopin(fitted(lm(y ~ xf + sin(x.1) + x.2, data = df)), fitted(ga))
[1] TRUE
> 
> ### check centering
> y <- rnorm(200)
> xn <- rnorm(200)
> xnm <- xn - mean(xn)
> xf <- gl(2, 100)
> gc <- gamboost(y ~ xn + xf)
Warning message:
In bbs(as.data.frame(list(...)), df = dfbase) :
  cannot compute 'bbs' for non-numeric variables; used 'bols' instead.
> g <- gamboost(y ~ xnm + xf)
Warning message:
In bbs(as.data.frame(list(...)), df = dfbase) :
  cannot compute 'bbs' for non-numeric variables; used 'bols' instead.
> print(max(abs(fitted(gc) - fitted(g))) < 1 / 10000)
[1] TRUE
> 
> pc1 <- predict(gc)
> pc2 <- predict(gc, newdata = data.frame(xn = xn, xf = xf))
> pc3 <- predict(g)
> print(.all.equal(pc1, pc2))
[1] TRUE
> print(max(abs(pc2 - pc3)) < 1 / 10000)
[1] TRUE
> 
> ### formula interfaces
> tmp <- data.frame(x1 = runif(100), x2 = runif(100), y = rnorm(100))
> fm1 <- y ~ bbs(x1, df = 3) + bbs(x2, df = 3)
> fm2 <- y ~ x1 + x2
> mod1 <- gamboost(fm1, data = tmp)
> mod2 <- gamboost(fm2, data = tmp, base = "bss", dfbase = 3)
Warning message:
In gamboost(fm2, data = tmp, base = "bss", dfbase = 3) :
  bss and bns are deprecated, bbs is used instead
> print(max(abs(fitted(mod1) - fitted(mod2))) < sqrt(.Machine$double.eps))
[1] TRUE
> print(max(abs(predict(mod1, newdata = tmp) - predict(mod2, newdata = tmp))) < sqrt(.Machine$double.eps))
[1] TRUE
> 
> fm1 <- y ~ bbs(x1, df = 3) + bbs(x2, df = 3)
> fm2 <- y ~ x1 + x2
> mod1 <- gamboost(fm1, data = tmp)
> mod2 <- gamboost(fm2, data = tmp, base = "bbs", dfbase = 3)
> print(max(abs(fitted(mod1) - fitted(mod2)))  < sqrt(.Machine$double.eps))
[1] TRUE
> print(max(abs(predict(mod1, newdata = tmp) - predict(mod2, newdata = tmp)))  < sqrt(.Machine$double.eps))
[1] TRUE
> 
> fm1 <- y ~ bols(x1) + bols(x2)
> fm2 <- y ~ x1 + x2
> mod1 <- gamboost(fm1, data = tmp)
> mod2 <- gamboost(fm2, data = tmp, base = "bols")
> print(max(abs(fitted(mod1) - fitted(mod2)))  < sqrt(.Machine$double.eps))
[1] TRUE
> print(max(abs(predict(mod1, newdata = tmp) - predict(mod2, newdata = tmp)))  < sqrt(.Machine$double.eps))
[1] TRUE
> 
> fm1 <- y ~ btree(x1) + btree(x2)
> fm2 <- y ~ x1 + x2
> mod1 <- gamboost(fm1, data = tmp)
> mod2 <- gamboost(fm2, data = tmp, base = "btree")
> print(max(abs(fitted(mod1) - fitted(mod2)))  < sqrt(.Machine$double.eps))
[1] TRUE
> print(max(abs(predict(mod1, newdata = tmp) - predict(mod2, newdata = tmp)))  < sqrt(.Machine$double.eps))
[1] TRUE
> 
> ## Cox model
> 
> fit2 <- gamboost(Surv(futime, fustat) ~ bbs(age) +
+     bols(resid.ds) + bols(rx) + bols(ecog.ps), data = ovarian,
+     family = CoxPH(), control = boost_control(mstop = 1000))
> 
> A2 <- survFit(fit2)
> A2
$surv
       [,1]
 [1,] 0.995
 [2,] 0.988
 [3,] 0.979
 [4,] 0.967
 [5,] 0.912
 [6,] 0.858
 [7,] 0.803
 [8,] 0.732
 [9,] 0.657
[10,] 0.583
[11,] 0.474
[12,] 0.372

$time
 [1]  59 115 156 268 329 353 365 431 464 475 563 638

$n.event
 [1] 1 1 1 1 1 1 1 1 1 1 1 1

attr(,"class")
[1] "survFit"
> 
> newdata <- ovarian[c(1,3,12),]
> A2 <- survFit(fit2, newdata = newdata)
> A2
$surv
             1        3    12
 [1,] 7.22e-01 8.76e-01 0.998
 [2,] 4.46e-01 7.20e-01 0.994
 [3,] 2.39e-01 5.58e-01 0.989
 [4,] 1.04e-01 3.97e-01 0.983
 [5,] 1.84e-03 7.69e-02 0.953
 [6,] 3.06e-05 1.45e-02 0.924
 [7,] 3.26e-07 2.28e-03 0.893
 [8,] 5.96e-10 1.75e-04 0.851
 [9,] 3.90e-13 8.81e-06 0.805
[10,] 1.12e-16 3.18e-07 0.757
[11,] 8.91e-23 1.04e-09 0.681
[12,] 6.85e-30 1.31e-12 0.601

$time
 [1]  59 115 156 268 329 353 365 431 464 475 563 638

$n.event
 [1] 1 1 1 1 1 1 1 1 1 1 1 1

attr(,"class")
[1] "survFit"
> 
> ### gamboost with explicit intercept
> df <- data.frame(x = 1:100, y = rnorm(1:100), int = rep(1, 100))
> mod <- gamboost(y ~ bols(int, intercept = FALSE) + bols(x, intercept = FALSE), data = df,
+                 control = boost_control(mstop = 2500))
Warning message:
In bols(x, intercept = FALSE) :
  covariates should be (mean-) centered if 'intercept = FALSE'
> cf <- unlist(coef(mod))
> cf[1] <- cf[1] + mod$offset
> tmp <- max(abs(cf - coef(lm(y ~ x, data = df))))
> print(tmp < 1e-5)
[1] TRUE
> tmp <- max(abs(fitted(mod) - fitted(lm(y ~ x, data = df))))
> print(tmp < 1e-5)
[1] TRUE
> 
> ### predictions:
> data("bodyfat", package = "TH.data")
> amod <- gamboost(DEXfat ~ hipcirc + anthro3a, data = bodyfat, baselearner = "bbs")
> 
> agg <- c("none", "sum", "cumsum")
> whi <- list(NULL, 1, 2, c(1,2))
> for (i in 1:4){
+     pred <- vector("list", length=3)
+     for (j in 1:3){
+         pred[[j]] <- predict(amod, aggregate=agg[j], which = whi[[i]])
+     }
+     if (i == 1){
+         print(max(abs(pred[[2]] - pred[[3]][,ncol(pred[[3]])]))  < sqrt(.Machine$double.eps))
+         if ((pred[[2]] - rowSums(pred[[1]]))[1] - attr(coef(amod), "offset") < sqrt(.Machine$double.eps))
+             warning(sQuote("aggregate = sum"), " adds the offset, ", sQuote("aggregate = none"), " doesn't.")
+         print(max(abs(pred[[2]] - rowSums(pred[[1]]) - attr(coef(amod), "offset")))   < sqrt(.Machine$double.eps))
+     } else {
+         print(max(abs(pred[[2]] - sapply(pred[[3]], function(obj) obj[,ncol(obj)])))  < sqrt(.Machine$double.eps))
+         print(max(abs(pred[[2]] - sapply(pred[[1]], function(obj) rowSums(obj))))  < sqrt(.Machine$double.eps))
+     }
+ }
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
Warning message:
'aggregate = sum' adds the offset, 'aggregate = none' doesn't. 
> 
> # use names in which instead of numbers
> agg <- c("none", "sum", "cumsum")
> whi <- list(NULL, "hipcirc", "anthro3a", c("hipcirc", "anthro3a"))
> for (i in 1:4){
+     pred <- vector("list", length=3)
+     for (j in 1:3){
+         pred[[j]] <- predict(amod, aggregate=agg[j], which = whi[[i]])
+     }
+     if (i == 1){
+         print(max(abs(pred[[2]] - pred[[3]][,ncol(pred[[3]])]))  < sqrt(.Machine$double.eps))
+         if ((pred[[2]] - rowSums(pred[[1]]))[1] - attr(coef(amod), "offset") < sqrt(.Machine$double.eps))
+             warning(sQuote("aggregate = sum"), " adds the offset, ", sQuote("aggregate = none"), " doesn't.")
+         print(max(abs(pred[[2]] - rowSums(pred[[1]]) - attr(coef(amod), "offset")))   < sqrt(.Machine$double.eps))
+     } else {
+         print(max(abs(pred[[2]] - sapply(pred[[3]], function(obj) obj[,ncol(obj)])))  < sqrt(.Machine$double.eps))
+         print(max(abs(pred[[2]] - sapply(pred[[1]], function(obj) rowSums(obj))))  < sqrt(.Machine$double.eps))
+     }
+ }
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
Warning message:
'aggregate = sum' adds the offset, 'aggregate = none' doesn't. 
> 
> # use which to extract all effects for one covariate e.g. for plotting purposes
> amod <- gamboost(DEXfat ~ bols(hipcirc, intercept=FALSE) + bbs(hipcirc, df = 1, center=TRUE), data = bodyfat)
Warning message:
In bols(hipcirc, intercept = FALSE) :
  covariates should be (mean-) centered if 'intercept = FALSE'
> print(ncol(predict(amod, which="hip")) == 2 && all(rowSums(predict(amod, which="hip")) + attr(coef(amod), "offset") - predict(amod) < sqrt(.Machine$double.eps)))
[1] TRUE
> 
> amod <- gamboost(DEXfat ~ hipcirc + anthro3a + kneebreadth,
+                  data = bodyfat, baselearner = "bbs")
> pr1 <- predict(amod, aggre = "sum", which= 1:2)
> foo <- bodyfat[,names(bodyfat) %in% c("hipcirc", "anthro3a", "kneebreadth")]
> foo$kneebreadth <- mean(bodyfat$kneebreadth)
> pr2 <- predict(amod, aggre = "sum", newdata=foo)
> print(all(diff(rowSums(pr1) - pr2) < sqrt(.Machine$double.eps))) # changes in level are ok
[1] TRUE
> newData <- as.data.frame(rbind(colMeans(bodyfat)[-2], colMeans(bodyfat)[-2]+1*sapply(bodyfat, sd)[-2]))
> if (!is.list(pr <- predict(amod, newdata=newData, which=1:2)))
+     warning("predict(amod, newdata=newData, which=1:2) does not return a list") # no list but a matrix is returned!
Warning message:
predict(amod, newdata=newData, which=1:2) does not return a list 
> print(is.list(pr <- predict(amod, newdata=newData, aggregate="cumsum", which=1:2)))
[1] TRUE
> amod[10]

	 Model-based Boosting

Call:
gamboost(formula = DEXfat ~ hipcirc + anthro3a + kneebreadth,     data = bodyfat, baselearner = "bbs")


	 Squared Error (Regression) 

Loss function: (y - f)^2 
 

Number of boosting iterations: mstop = 10 
Step size:  0.1 
Offset:  30.8 
Number of baselearners:  3 

> pr <- predict(amod, which=1:3)
> print(ncol(pr) == 3 || all(pr[,ncol] == 0))
[1] TRUE
> amod[100]

	 Model-based Boosting

Call:
gamboost(formula = DEXfat ~ hipcirc + anthro3a + kneebreadth,     data = bodyfat, baselearner = "bbs")


	 Squared Error (Regression) 

Loss function: (y - f)^2 
 

Number of boosting iterations: mstop = 100 
Step size:  0.1 
Offset:  30.8 
Number of baselearners:  3 

> 
> # check type argument
> set.seed(1907)
> x1 <- rnorm(100)
> p <- 1/(1 + exp(- 3 * x1))
> y <- as.factor(runif(100) < p)
> DF <- data.frame(y = y, x1 = x1)
> 
> logitBoost <- gamboost(y ~ x1, family = Binomial(),
+                  data = DF, baselearner = "bols", control=boost_control(mstop=5000))
> logit <- glm(y ~ x1, data=DF, family=binomial)
> print(coef(logitBoost)[[1]][2]*2 - coef(logit)[2]  < sqrt(.Machine$double.eps)) # * 2 as we use y = {-1, 1}
  bl 
TRUE 
> 
> pr <- predict(logitBoost)
> pr2 <- predict(logit)
> print(pr * 2 - pr2 < 1e-5)  # * 2 as we use y = {-1, 1}
       [,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
> 
> pr <- predict(logitBoost, type="class")
> pr2 <- predict(logit, type="response") > 0.5
> foo <- table(pr, pr2)
> print(foo[1,2] + foo[2,1] == 0)
[1] TRUE
> 
> pr <- predict(logitBoost, type="response")
> pr2 <- predict(logit, type="response")
> print(pr - pr2  < 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
> 
> ### coefficients:
> data("bodyfat", package = "TH.data")
> amod <- gamboost(DEXfat ~ hipcirc + anthro3a + kneebreadth,
+                  data = bodyfat, baselearner = "bbs")
> print(length(coef(amod)) == 3)
[1] TRUE
> amod[10]

	 Model-based Boosting

Call:
gamboost(formula = DEXfat ~ hipcirc + anthro3a + kneebreadth,     data = bodyfat, baselearner = "bbs")


	 Squared Error (Regression) 

Loss function: (y - f)^2 
 

Number of boosting iterations: mstop = 10 
Step size:  0.1 
Offset:  30.8 
Number of baselearners:  3 

> print(length(coef(amod)) == 2)
[1] TRUE
> print(length(coef(amod, which=1:3)) == 3)
[1] TRUE
> 
> ### cyclic covariates
> x <- seq(from = 0, to = 2*pi, length = 100)
> y <- sin(x) + rnorm(length(x), sd = 0.5)
> mod <- gamboost(y ~ bbs(x, cyclic = TRUE))
> print(diff(fitted(mod)[c(1, 100)]) == 0)
 100 
TRUE 
> 
> ### buser
> set.seed(1907)
> x <- rnorm(100)
> y <- rnorm(100, mean = x^2, sd = 0.1)
> mod1 <- gamboost(y ~ bbs(x))
> X <- extract(bbs(x))
> K <- extract(bbs(x), "penalty")
> mod2 <- gamboost(y ~ buser(X, K))
> print(max(abs(predict(mod1) - predict(mod2))) < sqrt(.Machine$double.eps))
[1] TRUE
> 
> z <- sample(1:2, 100, replace=TRUE)
> y[z == 2] <- rnorm(100, mean = - x^2, sd = 0.1)[z == 2]
> z <- as.factor(z)
> mod3 <- gamboost(y ~ bbs(x) + bbs(x, by = z),
+                  control = boost_control(mstop = 1000))
> X <- extract(bbs(x))
> K <- extract(bbs(x), "penalty")
> mod4 <- gamboost(y ~  buser(X, K) + buser(X, K, by = z),
+                  control = boost_control(mstop = 1000))
> print(max(abs(predict(mod3) - predict(mod4))) < sqrt(.Machine$double.eps))
[1] TRUE
> 
> y <- rnorm(100, mean = as.numeric(z), sd = 0.1)
> mod5 <- gamboost(y ~ bols(z))
> X <- extract(bols(z))
> K <- extract(bols(z), "penalty")
> index <- extract(bols(z), "index")
> mod6 <- gamboost(y ~  buser(X, K, lambda = 0, index = index))
> mod6a <- gamboost(y ~  buser(X, index = index))
> print(max(abs(predict(mod5) - predict(mod6))) < sqrt(.Machine$double.eps))
[1] TRUE
> print(max(abs(predict(mod5) - predict(mod6a))) < sqrt(.Machine$double.eps))
[1] TRUE
> 
> z <- sample(1:3, 100, replace = TRUE)
> y <- rnorm(100, mean = z, sd = 0.1)
> z <- as.ordered(z)
> mod7 <- gamboost(y ~ bols(z))
> X <- extract(bols(z))
> K <- extract(bols(z), "penalty")
> index <- extract(bols(z), "index")
> mod8 <- gamboost(y ~  buser(X, K, lambda = 0, index = index))
> print(max(abs(predict(mod7) - predict(mod8))) < sqrt(.Machine$double.eps))
[1] TRUE
> 
> y[z == 1] <- rnorm(100, mean = x^2, sd = 0.1)[z == 1]
> y[z == 2] <- rnorm(100, mean = - x^2, sd = 0.1)[z == 2]
> y[z == 3] <- rnorm(100, mean = x, sd = 0.1)[z == 3]
> mod9 <- gamboost(y ~ bbs(x) + bbs(x, by = z),
+                  control = boost_control(mstop = 1000))
Warning in Xfun(mf, vary, args) :
  'df' equal to rank of null space (unpenalized part of P-spline);
  Consider larger value for 'df' or set 'center != FALSE'.
> X <- extract(bbs(x))
> K <- extract(bbs(x), "penalty")
> mod10 <- gamboost(y ~  buser(X, K) + buser(X, K, by = z),
+                  control = boost_control(mstop = 1000))
> print(max(abs(predict(mod9) - predict(mod10))) < sqrt(.Machine$double.eps))
[1] TRUE
> 
> 
> ## test that mstop = 0 is possible
> compare_models <- function (m1, m2) {
+     print(.all.equal(coef(m1), coef(m2)))
+     print(.all.equal(predict(m1), predict(m2)))
+     print(.all.equal(fitted(m1), fitted(m2)))
+     print(.all.equal(as.vector(residuals(m1)), as.vector(residuals(m2))))
+     print(.all.equal(selected(m1), selected(m2)))
+     print(.all.equal(risk(m1), risk(m2)))
+     ## remove obvious differences from objects
+     m1$control <- m2$control <- NULL
+     m1$call <- m2$call <- NULL
+     if (!.all.equal(m1, m2))
+         stop("Objects of offset model + 1 step and model with 1 step not identical")
+     invisible(NULL)
+ }
> # set up models
> mod <- mboost(DEXfat ~ bbs(age) + bols(waistcirc) + bbs(hipcirc),
+               data = bodyfat, control = boost_control(mstop = 0))
> mod2 <- mboost(DEXfat ~ bbs(age) + bols(waistcirc) + bbs(hipcirc),
+                data = bodyfat, control = boost_control(mstop = 1))
> mod3 <- mboost(DEXfat ~ bbs(age) + bols(waistcirc) + bbs(hipcirc),
+                data = bodyfat, control = boost_control(mstop = 1))
> print(is.null(coef(mod)))
[1] TRUE
> print(predict(mod) == rep(mod$offset, nrow(bodyfat)))
  47   48   49   50   51   52   53   54   55   56   57   58   59   60   61   62 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
  63   64   65   66   67   68   69   70   71   72   73   74   75   76   77   78 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
  79   80   81   82   83   84   85   86   87   88   89   90   91   92   93   94 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
  95   96   97   98   99  100  101  102  103  104  105  106  107  108  109  110 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
 111  112  113  114  115  116  117 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
> print(fitted(mod) == rep(mod$offset, nrow(bodyfat)))
  47   48   49   50   51   52   53   54   55   56   57   58   59   60   61   62 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
  63   64   65   66   67   68   69   70   71   72   73   74   75   76   77   78 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
  79   80   81   82   83   84   85   86   87   88   89   90   91   92   93   94 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
  95   96   97   98   99  100  101  102  103  104  105  106  107  108  109  110 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
 111  112  113  114  115  116  117 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
> print(.all.equal(residuals(mod), bodyfat$DEXfat - mean(bodyfat$DEXfat)))
[1] TRUE
> print(is.null(selected(mod)))
[1] TRUE
> print(.all.equal(risk(mod), risk(mod2)[1]))
[1] TRUE
> 
> mstop(mod3) <- 0
> compare_models(mod, mod3)
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
> mstop(mod) <- 1
> compare_models(mod, mod2)
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
> mstop(mod3) <- 1
> compare_models(mod, mod3)
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
> 
> ## same with glmboost
> mod <- glmboost(DEXfat ~ age + waistcirc + hipcirc,
+                 data = bodyfat, control = boost_control(mstop = 0))
> mod2 <- glmboost(DEXfat ~ age + waistcirc + hipcirc,
+                  data = bodyfat, control = boost_control(mstop = 1))
> mod3 <- glmboost(DEXfat ~ age + waistcirc + hipcirc,
+                  data = bodyfat, control = boost_control(mstop = 1))
> print(is.null(coef(mod)))
[1] TRUE
> print(predict(mod) == rep(mod$offset, nrow(bodyfat)))
  47   48   49   50   51   52   53   54   55   56   57   58   59   60   61   62 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
  63   64   65   66   67   68   69   70   71   72   73   74   75   76   77   78 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
  79   80   81   82   83   84   85   86   87   88   89   90   91   92   93   94 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
  95   96   97   98   99  100  101  102  103  104  105  106  107  108  109  110 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
 111  112  113  114  115  116  117 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
> print(fitted(mod) == rep(mod$offset, nrow(bodyfat)))
  47   48   49   50   51   52   53   54   55   56   57   58   59   60   61   62 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
  63   64   65   66   67   68   69   70   71   72   73   74   75   76   77   78 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
  79   80   81   82   83   84   85   86   87   88   89   90   91   92   93   94 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
  95   96   97   98   99  100  101  102  103  104  105  106  107  108  109  110 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
 111  112  113  114  115  116  117 
TRUE TRUE TRUE TRUE TRUE TRUE TRUE 
> print(.all.equal(residuals(mod), bodyfat$DEXfat - mean(bodyfat$DEXfat), check.attributes = FALSE))
[1] TRUE
> print(is.null(selected(mod)))
[1] TRUE
> print(.all.equal(risk(mod), risk(mod2)[1]))
[1] TRUE
> 
> mstop(mod3) <- 0
> compare_models(mod, mod3)
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
> mstop(mod) <- 1
> compare_models(mod, mod2)
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
> mstop(mod3) <- 1
> compare_models(mod, mod3)
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
[1] TRUE
> 
> 
> proc.time()
   user  system elapsed 
  2.324   0.106   2.419 
