[Mboost-commits] r852 - in pkg/mboostDevel: R inst tests

[noreply at r-forge.r-project.org]

Author: hofner
Date: 2015-04-26 21:00:18 +0200 (Sun, 26 Apr 2015)
New Revision: 852

Modified:
   pkg/mboostDevel/R/bkronecker.R
   pkg/mboostDevel/R/bl.R
   pkg/mboostDevel/inst/NEWS.Rd
   pkg/mboostDevel/tests/regtest-baselearner.R
Log:
Bug in df2lambda fixed: Design matrices were always assumed to be of full rank.

Modified: pkg/mboostDevel/R/bkronecker.R
===================================================================
--- pkg/mboostDevel/R/bkronecker.R	2015-04-22 17:29:06 UTC (rev 851)
+++ pkg/mboostDevel/R/bkronecker.R	2015-04-26 19:00:18 UTC (rev 852)
@@ -61,7 +61,8 @@
         if (is.null(args$lambda)) {
 
             ### <FIXME>: is there a better way to feed XtX into lambdadf?
-            lambdadf <- df2lambda(matrix(0, ncol = ncol(X$X1) + ncol(X$X2)),
+            ### <FIXME>: is ncol(X$X1) + ncol(X$X2) ok or should it be rankMatrix(...)?
+            lambdadf <- df2lambda(X = diag(ncol(X$X1) + ncol(X$X2)),
                                   df = args$df, lambda = args$lambda,
                                   dmat = K, weights = weights, XtX = XtX)
             ### </FIXME>

Modified: pkg/mboostDevel/R/bl.R
===================================================================
--- pkg/mboostDevel/R/bl.R	2015-04-22 17:29:06 UTC (rev 851)
+++ pkg/mboostDevel/R/bl.R	2015-04-26 19:00:18 UTC (rev 852)
@@ -4,12 +4,22 @@
 df2lambda <- function(X, df = 4, lambda = NULL, dmat = NULL, weights,
                       XtX = NULL) {
 
-
     stopifnot(xor(is.null(df), is.null(lambda)))
-    if (!is.null(df))
-        if (df >= ncol(X)) return(c(df = df, lambda = 0))
+    if (!is.null(df)) {
+        rank_X <- rankMatrix(X, method = 'qr')
+        if (df >= rank_X) {
+            if (df > rank_X)
+                warning(sQuote("df"),
+                        " too large:\n  Degrees of freedom cannot be larger",
+                        " than the rank of the design matrix.\n",
+                        "  Unpenalized base-learner with df = ",
+                        rank_X, " used. Re-consider model specification.")
+            return(c(df = df, lambda = 0))
+        }
+    }
     if (!is.null(lambda))
-        if (lambda == 0) return(c(df = ncol(X), lambda = 0))
+        if (lambda == 0)
+            return(c(df = rankMatrix(X), lambda = 0))
 
     ## check for possible instability
     if (options("mboost_check_df2lambda")[[1]] && max(abs(X)) > 10)

Modified: pkg/mboostDevel/inst/NEWS.Rd
===================================================================
--- pkg/mboostDevel/inst/NEWS.Rd	2015-04-22 17:29:06 UTC (rev 851)
+++ pkg/mboostDevel/inst/NEWS.Rd	2015-04-26 19:00:18 UTC (rev 852)
@@ -39,6 +39,8 @@
       \item Bug in \code{df2lambda} fixed: Make sure that \code{A} is
       symmetric if it is \code{Matrix}-object (spotted by Souhaib Ben
       Taieb).
+      \item Bug in \code{df2lambda} fixed. Design matrices were always
+      assumed to be of full rank.
     }
   }
 }

Modified: pkg/mboostDevel/tests/regtest-baselearner.R
===================================================================
--- pkg/mboostDevel/tests/regtest-baselearner.R	2015-04-22 17:29:06 UTC (rev 851)
+++ pkg/mboostDevel/tests/regtest-baselearner.R	2015-04-26 19:00:18 UTC (rev 852)
@@ -152,6 +152,15 @@
 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)
+## df2lambda:
+stopifnot(df2lambda(X, df = NULL, lambda = 0, weights = rep(1, 100))[["df"]] == 3)
+(res <- df2lambda(X, df = 4, weights = rep(1, 100)))
+stopifnot(res[["lambda"]] == 0)
+
 ### componentwise
 cf2 <- coef(fit(dpp(bolscw(cbind(1, xn)), weights = w), y))
 cf1 <- coef(lm(y ~ xn - 1, weights = w))
@@ -370,11 +379,11 @@
 w <- as.vector(rmultinom(1, length(y), rep(1 / length(y), length(y))))
 
 m1 <- mboost(y ~ bbs(Var2, df = 3, knots = 5) %X%
-                     bbs(Var1, df = 3, knots = 7),
-                     data = d, weights = w)
-m2 <- mboost(y ~ bbs(x1, df = 3, knots = 7)%O%
+                 bbs(Var1, df = 3, knots = 7),
+             data = d, weights = w)
+m2 <- mboost(y ~ bbs(x1, df = 3, knots = 7) %O%
                  bbs(x2, df = 3, knots = 5),
-                 weights = w)
+             weights = w)
 
 stopifnot(max(abs(fitted(m1) - fitted(m2))) < tol)