Running ‘birds_Biometrics.R’ [4s/4s]
  Comparing ‘birds_Biometrics.Rout’ to ‘birds_Biometrics.Rout.save’ ... OK
  Running ‘bugfixes.R’ [13s/13s]
  Comparing ‘bugfixes.Rout’ to ‘bugfixes.Rout.save’ ... OK
  Running ‘regtest-baselearner.R’ [2s/2s]
Running the tests in ‘tests/regtest-baselearner.R’ failed.
Complete output:
  > 
  > options(digits = 3)
  > 
  > .all.equal <- function(...) isTRUE(all.equal(..., check.environment = FALSE))
  > 
  > library("mboost")
  Loading required package: parallel
  Loading required package: stabs
  > attach(asNamespace("mboost"))
  The following objects are masked from package:mboost:
  
      %+%, %O%, %X%, AUC, AdaExp, Binomial, Cindex, CoxPH, ExpectReg, FP,
      Family, GammaReg, GaussClass, GaussReg, Gaussian, Gehan, Huber,
      Hurdle, IPCweights, Laplace, Loglog, Lognormal, Multinomial,
      NBinomial, Poisson, PropOdds, QuantReg, RCG, Weibull,
      as.data.frame.varimp, bbs, bkernel, blackboost, bmono, bmrf, bns,
      bols, boost_control, brad, brandom, bspatial, bss, btree, buser,
      confint.glmboost, confint.mboost, cv, cvrisk, downstream.test,
      extract, fitted.mboost, gamboost, glmboost, lines.mboost,
      lines.mboost.ci, mboost, mboost_fit, mboost_intern, mstop, mstop<-,
      nuisance, plot.cvrisk, plot.glmboost, plot.mboost, plot.mboost.ci,
      plot.varimp, predict.glmboost, predict.mboost, print.glmboost.ci,
      risk, selected.mboost, stabsel.mboost, stabsel_parameters.mboost,
      survFit, varimp
  
  > 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) : base-learner contains missing values;
  missing values are excluded per base-learner, i.e., base-learners may depend on different numbers of observations.
  > testfun(m1, m2)
  > 
  > ### numeric x without intercept
  > m1 <- lm(y ~ xn - 1, weights = w, na.action = na.exclude)
  > m2 <- fit(dpp(bols(xn, intercept = FALSE), w), y)
  Warning messages:
  1: In bols(xn, intercept = FALSE) :
    covariates should be (mean-) centered if 'intercept = FALSE'
  2: In bols(xn, intercept = FALSE) : base-learner contains missing values;
  missing values are excluded per base-learner, i.e., base-learners may depend on different numbers of observations.
  > testfun(m1, m2)
  > 
  > ### factor x with intercept
  > m1 <- lm(y ~ xf, weights = w, na.action = na.exclude)
  > m2 <- fit(dpp(bols(xf), w), y)
  Warning message:
  In bols(xf) : base-learner contains missing values;
  missing values are excluded per base-learner, i.e., base-learners may depend on different numbers of observations.
  > testfun(m1, m2)
  > 
  > ### factor x without intercept
  > tmp <- model.matrix(~ xf)[,-1] ## build model matrix without first row
  > mm <- matrix(NA, ncol = ncol(tmp), nrow = length(y))
  > mm[!is.na(xf),] <- tmp ## build model matrix with missings
  > m1 <- lm(y ~ mm - 1, weights = w, na.action = na.exclude)
  > m2 <- fit(dpp(bols(xf, intercept = FALSE), w), y)
  Warning message:
  In bols(xf, intercept = FALSE) : base-learner contains missing values;
  missing values are excluded per base-learner, i.e., base-learners may depend on different numbers of observations.
  > testfun(m1, m2)
  > 
  > ### factor x with "contr.dummy"
  > m1 <- lm(y ~ xf - 1, weights = w, na.action = na.exclude)
  > m2 <- fit(dpp(bols(xf, contrasts.arg = "contr.dummy"), w), y)
  Warning message:
  In bols(xf, contrasts.arg = "contr.dummy") :
    base-learner contains missing values;
  missing values are excluded per base-learner, i.e., base-learners may depend on different numbers of observations.
  > testfun(m1, m2)
  > 
  > ### contrasts
  > m1 <- lm(y ~ xf, weights = w, contrasts = list(xf = "contr.sum"), na.action = na.exclude)
  > m2 <- fit(dpp(bols(xf, contrasts.arg = list(xf = "contr.sum")), w), y)
  Warning message:
  In bols(xf, contrasts.arg = list(xf = "contr.sum")) :
    base-learner contains missing values;
  missing values are excluded per base-learner, i.e., base-learners may depend on different numbers of observations.
  > testfun(m1, m2)
  > 
  > ### multiple x
  > m1 <- lm(y ~ xn + xf, weights = w, na.action = na.exclude)
  > m2 <- fit(dpp(bols(xn, xf), w), y)
  Warning message:
  In bols(xn, xf) : base-learner contains missing values;
  missing values are excluded per base-learner, i.e., base-learners may depend on different numbers of observations.
  > testfun(m1, m2)
  > 
  > ### interaction with binary factor
  > xtmp <- (z1 == "2") * xn
  > m1 <- lm(y ~ xtmp - 1, weights = w, na.action = na.exclude)
  > m2 <- fit(dpp(bols(xn, by = z1, intercept = FALSE), w), y)
  Warning messages:
  1: In bols(xn, by = z1, intercept = FALSE) :
    covariates should be (mean-) centered if 'intercept = FALSE'
  2: In bols(xn, by = z1, intercept = FALSE) :
    base-learner contains missing values;
  missing values are excluded per base-learner, i.e., base-learners may depend on different numbers of observations.
  > testfun(m1, m2)
  > 
  > ### interaction with numeric variable
  > m1 <- lm(y ~ z2:xn - 1, weights = w, na.action = na.exclude)
  > m2 <- fit(dpp(bols(z2, by = xn, intercept = FALSE), w), y)
  Warning messages:
  1: In bols(z2, by = xn, intercept = FALSE) :
    covariates should be (mean-) centered if 'intercept = FALSE'
  2: In bols(z2, by = xn, intercept = FALSE) :
    base-learner contains missing values;
  missing values are excluded per base-learner, i.e., base-learners may depend on different numbers of observations.
  > testfun(m1, m2)
  > 
  > ### ridge
  > one <- rep(1, n)
  > cf1 <- coef(lm.ridge(y ~ one + xn - 1, lambda = 2))
  > cf2 <- coef(fit(dpp(bols(one, xn, lambda = 2, intercept = FALSE), rep(1, n)), y))
  Warning message:
  In bols(one, xn, lambda = 2, intercept = FALSE) :
    base-learner contains missing values;
  missing values are excluded per base-learner, i.e., base-learners may depend on different numbers of observations.
  > max(abs(cf1 - cf2))
  [1] 0.00162
  > cf1 <- coef(lm.ridge(y ~ xf - 1, lambda = 2))
  > cf2 <- coef(fit(dpp(bols(xf, lambda = 2, intercept = FALSE), rep(1, n)), y))
  Warning message:
  In bols(xf, lambda = 2, intercept = FALSE) :
    base-learner contains missing values;
  missing values are excluded per base-learner, i.e., base-learners may depend on different numbers of observations.
  > max(abs(cf1 - cf2))
  [1] 0.0432
  Warning message:
  In cf1 - cf2 :
    longer object length is not a multiple of shorter object length
  > 
  > ### matrix (here with missing values)
  > cf1 <- coef(mod <- lm(y ~ xn + xf * z1 - 1, weights = w, y = TRUE, x = TRUE))
  > tX <- mod$x
  > tw <- mod$weights
  > ty <- mod$y
  > cf2 <- coef(fit(dpp(bols(tX), weights = tw), ty))
  > stopifnot(max(abs(cf1 - cf2)) < sqrt(.Machine$double.eps))
  > 
  > ### ridge again with matrix interface
  > tX <- matrix(runif(1000), ncol = 10)
  > ty <- rnorm(100)
  > tw <- rep(1, 100)
  > 
  > ### compute & check df
  > op <- options(mboost_dftraceS = TRUE)
  > la <- df2lambda(tX, df = 2, dmat = diag(ncol(tX)), weights = tw)["lambda"]
  > truedf <- sum(diag(tX %*% solve(crossprod(tX * tw, tX) + la * diag(ncol(tX))) %*% t(tX * tw)))
  > stopifnot(abs(truedf - 2) < sqrt(.Machine$double.eps))
  > 
  > one <- rep(1, ncol(tX))
  > cf1 <- coef(lm.ridge(ty ~ . - 1, data = as.data.frame(tX), lambda = la))
  > cf2 <- coef(fit(dpp(bols(tX, df = 2), weights = tw), ty))
  > max(abs(cf1 - cf2))
  [1] 0.115
  > # I think bols is better and thus right
  > sum((ty - tX %*% cf1)^2) + la * sum(cf1^2)
  lambda 
     106 
  > sum((ty - tX %*% cf2)^2) + la * sum(cf2^2)
  lambda 
     105 
  > options(op)
  > 
  > ### now with other df-definition:
  > op <- options(mboost_dftraceS = FALSE)
  > la <- df2lambda(tX, df = 2, dmat = diag(ncol(tX)), weights = tw)["lambda"]
  > H <- tX %*% solve(crossprod(tX * tw, tX) + la * diag(ncol(tX))) %*% t(tX * tw)
  > truedf <- sum(diag(2*H - tcrossprod(H,H)))
  > stopifnot(abs(truedf - 2) < sqrt(.Machine$double.eps))
  > options(op)
  > 
  > # check df with weights
  > op <- options(mboost_dftraceS = TRUE)
  > tw <- rpois(100, 2)
  > la <- df2lambda(tX, df = 2, dmat = diag(ncol(tX)), weights = tw)["lambda"]
  > truedf <- sum(diag(tX %*% solve(crossprod(tX * tw, tX) + la * diag(ncol(tX))) %*% t(tX * tw)))
  > stopifnot(abs(truedf - 2) < sqrt(.Machine$double.eps))
  > 
  > ### check df2lambda for P-splines (Bug spotted by B. Hofner)
  > set.seed(1907)
  > x <- runif(100, min = -1, max = 3)
  > ## extract lambda from base-learner
  > lambda <- bbs(x, df = 4)$dpp(rep(1, length(x)))$df()["lambda"]
  > X <- get("X", envir = environment(bbs(x, df = 4)$dpp))
  > K <- get("K", envir = environment(bbs(x, df = 4)$dpp))
  > truedf <- sum(diag(X %*%  solve(crossprod(X,X) + lambda * K) %*% t(X)))
  > stopifnot(abs(truedf - 4) < sqrt(.Machine$double.eps))
  > 
  > ### check accuracy of df2lambda
  > data("bodyfat", package="TH.data")
  > diff_df <- matrix(NA, nrow=8, ncol=ncol(bodyfat))
  > rownames(diff_df) <- paste("df", 3:10)
  > colnames(diff_df) <- names(bodyfat)
  > for (i in 3:10){
  +     for (j in 1:ncol(bodyfat)){
  +         lambda <- bbs(bodyfat[[j]], df = i)$dpp(rep(1, nrow(bodyfat)))$df()["lambda"]
  +         diff_df[i-2,j] <- bbs(bodyfat[[j]], lambda = lambda)$dpp(rep(1, nrow(bodyfat)))$df()["df"] - i
  +     }
  + }
  > stopifnot(all(diff_df < sqrt(.Machine$double.eps)))
  > options(op)
  > 
  > ### check degrees of freedom for design matrices without full rank:
  > x <- sample(1:3, 100, replace = TRUE)
  > X <- extract(bbs(x))
  > rankMatrix(X)
  [1] 3
  attr(,"method")
  [1] "tolNorm2"
  attr(,"useGrad")
  [1] FALSE
  attr(,"tol")
  [1] 2.22e-14
  > ## df2lambda:
  > stopifnot(df2lambda(X, df = NULL, lambda = 0, weights = rep(1, 100))[["df"]] == 3)
  > (res <- df2lambda(X, df = 4, weights = rep(1, 100)))
      df lambda 
       4      0 
  Warning message:
  In df2lambda(X, df = 4, weights = rep(1, 100)) : 'df' too large:
    Degrees of freedom cannot be larger than the rank of the design matrix.
    Unpenalized base-learner with df = 3 used. Re-consider model specification.
  > stopifnot(res[["lambda"]] == 0)
  > 
  > ### componentwise
  > cf2 <- coef(fit(dpp(bolscw(cbind(1, xn)), weights = w), y))
  > cf1 <- coef(lm(y ~ xn - 1, weights = w))
  > stopifnot(max(abs(cf1 - max(cf2))) < sqrt(.Machine$double.eps))
  > 
  > cf2 <- coef(fit(dpp(bolscw(matrix(xn, nc = 1)), weights = w), y))
  > cf1 <- coef(lm(y ~ xn - 1, weights = w))
  > stopifnot(max(abs(cf1 - max(cf2))) < sqrt(.Machine$double.eps))
  > 
  > ### componentwise with matrix
  > n <- 200
  > m <- 10000
  > x <- rnorm(n * m)
  > x[abs(x) < 2] <- 0
  > X <- Matrix(data = x, ncol = m, nrow = n)
  > beta <- rpois(ncol(X), lambda = 1)
  > y <- X %*% beta + rnorm(nrow(X))
  > w <- rep(1, nrow(X)) ###rpois(nrow(X), lambda = 1)
  > f1 <- dpp(bolscw(X), weights = w)$fit
  > f1(y)$model
     coef xselect       p 
    -30.7   951.0 10000.0 
  > 
  > ### varying coefficients
  > x1 <- runif(n, max = 2)
  > x2 <- sort(runif(n, max = 2 * pi))
  > y <- sin(x2) * x1 + rnorm(n)
  > w <- rep(1, n)
  > 
  > d <- dpp(bbs(x2, by = x1, df = 4), w)
  > f <- fit(d, y)
  > f2 <- d$predict(list(f), newdata = data.frame(x1 = 1, x2 = x2))
  > 
  > max(abs(sin(x2) - f2))
  [1] 0.778
  > 
  > ### bols and bbs; matrix interfaces
  > n <- 10000
  > x <- runif(n, min = 0, max = 2*pi)
  > y <- sin(x) + rnorm(n, sd = 0.1)
  > w <- rpois(n, lambda = 1)
  > x[sample(1:n)[1:(n / 100)]] <- NA
  > h <- hyper_bbs(data.frame(x = x), vary = "")
  > X <- X_bbs(data.frame(x = x), vary = "", h)$X
  > f1 <- fit(dpp(bbs(x, df = ncol(X)), w), y)
  Warning message:
  In bbs(x, df = ncol(X)) : base-learner contains missing values;
  missing values are excluded per base-learner, i.e., base-learners may depend on different numbers of observations.
  > f2 <- fit(dpp(bols(X, df = ncol(X)), w), y)
  Warning message:
  In bols(X, df = ncol(X)) : base-learner contains missing values;
  missing values are excluded per base-learner, i.e., base-learners may depend on different numbers of observations.
  > stopifnot(max(abs(coef(f1) - coef(f2))) < sqrt(.Machine$double.eps))
  > 
  > stopifnot(.all.equal(get_index(data.frame(x, x)), get_index(X)))
  > stopifnot(.all.equal(get_index(data.frame(x)), get_index(X)))
  > 
  > ### check handling of missings for cyclic effects
  > h <- hyper_bbs(data.frame(x = x), vary = "", cyclic = TRUE)
  > X <- X_bbs(data.frame(x = x), vary = "", h)$X
  > stopifnot(all(is.na(X[is.na(x),])))
  > stopifnot(all(!is.na(X[!is.na(x),])))
  > 
  > ### combinations and tensor products of base-learners
  > 
  > set.seed(29)
  > n <- 1000
  > x1 <- rnorm(n)
  > x2 <- rnorm(n)
  > x3 <- rnorm(n)
  > f <- gl(4, 25)
  > y <- rnorm(n)
  > ndf <- data.frame(x1 = x1[1:10], x2 = x2[1:10], f = f[1:10])
  > 
  > ### spatial
  > m1 <- gamboost(y ~ bbs(x1) %X% bbs(x2))
  Warning message:
  In .qr.rank.def.warn(r) :
    matrix is structurally rank deficient; using augmented matrix with additional 203 row(s) of zeros
  > m2 <- gamboost(y ~ bspatial(x1, x2, df = 16))
  Warning message:
  In .qr.rank.def.warn(r) :
    matrix is structurally rank deficient; using augmented matrix with additional 203 row(s) of zeros
  > stopifnot(max(abs(predict(m1) - predict(m2))) < sqrt(.Machine$double.eps))
  Error: max(abs(predict(m1) - predict(m2))) < sqrt(.Machine$double.eps) is not TRUE
  Execution halted