[Mboost-commits] r854 - / pkg/mboostDevel/R

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

Author: hofner
Date: 2015-06-24 16:51:11 +0200 (Wed, 24 Jun 2015)
New Revision: 854

Modified:
   README.md
   pkg/mboostDevel/R/bkronecker.R
   pkg/mboostDevel/R/stabsel.R
Log:
try to handle violations; Update README.md

Modified: README.md
===================================================================
--- README.md	2015-04-27 11:19:21 UTC (rev 853)
+++ README.md	2015-06-24 14:51:11 UTC (rev 854)
@@ -1,7 +1,8 @@
 mboost
 ======
 
-[![Build Status](https://travis-ci.org/hofnerb/mboost.svg?branch=master)](https://travis-ci.org/hofnerb/mboost)
+[![Build Status](https://travis-ci.org/hofnerb/mboost.svg?branch=master)](https://travis-ci.org/hofnerb/mboost) 
+[![](http://cranlogs.r-pkg.org/badges/mboost)](http://cran.rstudio.com/web/packages/mboost/index.html)
 
 `mboost` implements boosting algorithms for fitting generalized linear, additive and interaction models 
 to potentially high-dimensional data. 

Modified: pkg/mboostDevel/R/bkronecker.R
===================================================================
--- pkg/mboostDevel/R/bkronecker.R	2015-04-27 11:19:21 UTC (rev 853)
+++ pkg/mboostDevel/R/bkronecker.R	2015-06-24 14:51:11 UTC (rev 854)
@@ -41,7 +41,7 @@
 
     dpp <- function(weights) {
 
-        if (!is.null(attr(X$X1, "deriv")) || !is.null(attr(X$X2, "deriv"))) 
+        if (!is.null(attr(X$X1, "deriv")) || !is.null(attr(X$X2, "deriv")))
             stop("fitting of derivatives of B-splines not implemented")
 
         W <- matrix(weights, nrow = n1, ncol = n2)
@@ -53,7 +53,7 @@
         XtX <- array(XtX, c(c1, c1, c2, c2))
         XtX <- mymatrix(aperm(XtX, c(1, 3, 2, 4)), nrow = c1 * c2)
 
-        ### If lambda was given in both baselearners, we 
+        ### If lambda was given in both baselearners, we
         ### directly multiply the marginal penalty matrices by lambda
         ### and then compute the total penalty as the kronecker sum.
         ### args$lambda is NA in this case and we don't compute
@@ -74,10 +74,10 @@
         XtX <- XtX + K
 
         ### nnls
-        constr <- (!is.null(attr(X$X1, "constraint"))) + 
+        constr <- (!is.null(attr(X$X1, "constraint"))) +
                   (!is.null(attr(X$X2, "constraint")))
 
-        if (constr == 2) 
+        if (constr == 2)
             stop("only one dimension may be subject to constraints")
         constr <- constr > 0
 
@@ -234,7 +234,7 @@
     l1 <- args1$lambda
     l2 <- args2$lambda
     if (xor(is.null(l1), is.null(l2)))
-        stop("lambda needs to be given in both baselearners combined with ", 
+        stop("lambda needs to be given in both baselearners combined with ",
              sQuote("%O%"))
     if (!is.null(l1) && !is.null(l2)) {
         ### there is no common lambda!

Modified: pkg/mboostDevel/R/stabsel.R
===================================================================
--- pkg/mboostDevel/R/stabsel.R	2015-04-27 11:19:21 UTC (rev 853)
+++ pkg/mboostDevel/R/stabsel.R	2015-06-24 14:51:11 UTC (rev 854)
@@ -72,16 +72,16 @@
         names(selected) <- nms
         selected[unique(xs)] <- TRUE
 
-        if (verbose && sum(selected) < q)
-            violations[i] <<- TRUE
-
         ## compute selection paths
         sel_paths <- matrix(FALSE, nrow = length(nms), ncol = mstop)
         rownames(sel_paths) <- nms
         for (j in 1:length(xs))
             sel_paths[xs[j], j:mstop] <- TRUE
 
-        return(list(selected = selected, path = sel_paths))
+        ret <- list(selected = selected, path = sel_paths)
+        ## was mstop to small?
+        attr(ret, "violations") <- ifelse(sum(selected) < q, TRUE, FALSE)
+        return(ret)
     }
 
     ret <- run_stabsel(fitter = fit_model, args.fitter = list(),
@@ -97,6 +97,9 @@
     if (!eval)
         return(ret)
 
+    if (!is.null(attr(ret, "violations")))
+        violations <- attr(ret, "violations")
+
     if (any(violations))
         warning(sQuote("mstop"), " too small in ",
                 sum(violations), " of the ", length(violations),