fix selected and adapt tests

boost-R · May 2, 2017 · 1e606c7 · 1e606c7
1 parent b66755c
commit 1e606c7
Show file tree

Hide file tree

Showing 3 changed files with 9 additions and 7 deletions.
diff --git a/R/methods.R b/R/methods.R
@@ -98,15 +98,16 @@ selected.mboostLSS <- function(object, merge = FALSE, parameter = names(object),
     if (merge) {
         if (inherits(object, "nc_mboostLSS")){
 
-## <FIXME> What should this return? At least when one parameter was never selected this is broken (and also the next lines)
-            RET <- names(attr(object, "combined_risk")())
+            #get the names of parameter selected in each iteration (drop initial offset risk values)
+            RET <- names(attr(object, "combined_risk")())[-seq_along(parameter)]
+            names(RET) <- RET #set the names of the vector as we will overwrite the values.
 
+            #overwrite names in the vector with the selected BLs in the correct order
             for(p in names(parameter)){
                 RET[RET == p] <- object[[p]]$xselect()
             }
-            RET <- as.numeric(RET)
-            names(RET) <- names(attr(object, "combined_risk")())
-## </FIXME>            
+            mode(RET) = "numeric" #ensure numeric values -> as.numeric drops the names
+
             return(RET)
         }
         else {

diff --git a/tests/regtest-noncyclic_fitting.R b/tests/regtest-noncyclic_fitting.R
@@ -158,13 +158,13 @@ for( i in 1:500)
 dat <- data.frame(x1, x2, x3, x4, x5, x6, y)
 
 model <- glmboostLSS(y ~ ., families = NBinomialLSS(), data = dat,
-                     control = boost_control(mstop = 10),
+                     control = boost_control(mstop = 20),
                      center = TRUE, method = "cyclic")
 selected(model) # ok (at least in principle)
 selected(model, merge = TRUE) # ok
 
 model <- glmboostLSS(y ~ ., families = NBinomialLSS(), data = dat,
-                     control = boost_control(mstop = 10),
+                     control = boost_control(mstop = 20),
                      center = TRUE, method = "noncyclic")
 selected(model) # ok (at least in principle)
 selected(model, merge = TRUE) ## BROKEN

diff --git a/tests/regtest-stabsel.R b/tests/regtest-stabsel.R
@@ -1,3 +1,4 @@
+require("gamboostLSS")
 ### Data generating process:
 set.seed(1907)
 x1 <- rnorm(500)