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

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

Author: hofner
Date: 2015-04-02 11:20:44 +0200 (Thu, 02 Apr 2015)
New Revision: 842

Modified:
   pkg/mboostDevel/R/crossvalidation.R
   pkg/mboostDevel/inst/NEWS.Rd
   pkg/mboostDevel/man/cvrisk.Rd
   pkg/mboostDevel/tests/regtest-inference.R
Log:
(cvrisk) better handling of errors in folds:
results of folds without errors are used and a warning is issued

Modified: pkg/mboostDevel/R/crossvalidation.R
===================================================================
--- pkg/mboostDevel/R/crossvalidation.R	2015-04-02 09:20:41 UTC (rev 841)
+++ pkg/mboostDevel/R/crossvalidation.R	2015-04-02 09:20:44 UTC (rev 842)
@@ -9,7 +9,8 @@
 
 cvrisk.mboost <- function (object, folds = cv(model.weights(object)),
                            grid = 1:mstop(object), papply = mclapply,
-                           fun = NULL, corrected = TRUE, ...) {
+                           fun = NULL, corrected = TRUE, mc.preschedule = FALSE,
+                           ...) {
 
     weights <- model.weights(object)
     if (any(weights == 0))
@@ -71,12 +72,27 @@
     ## use case weights as out-of-bag weights (but set inbag to 0)
     OOBweights <- matrix(rep(weights, ncol(folds)), ncol = ncol(folds))
     OOBweights[folds > 0] <- 0
-    oobrisk <- papply(1:ncol(folds),
-        function(i) dummyfct(weights = folds[, i],
-                             oobweights = OOBweights[, i]), ...)
-    ## get errors if mclapply is used
-    if (any(idx <- sapply(oobrisk, is.character)))
-        stop(sapply(oobrisk[idx], function(x) x))
+    if (all.equal(papply, mclapply) == TRUE) {
+        oobrisk <- papply(1:ncol(folds),
+                          function(i) dummyfct(weights = folds[, i],
+                                               oobweights = OOBweights[, i]),
+                          mc.preschedule = mc.preschedule,
+                          ...)
+    } else {
+        oobrisk <- papply(1:ncol(folds),
+                          function(i) try(dummyfct(weights = folds[, i],
+                                                   oobweights = OOBweights[, i])),
+                          ...)
+    }
+    ## if any errors if mclapply was used: remove result and issue a warning
+    if (any(idx <- sapply(oobrisk, is.character))) {
+        warning(sum(idx), " fold(s) encountered an error. ",
+                "Results are based on ", ncol(folds) - sum(idx),
+                " folds only.\n",
+                "Original error message(s):\n",
+                sapply(oobrisk[idx], function(x) x))
+        oobrisk[idx] <- NULL
+    }
     if (!is.null(fun))
         return(oobrisk)
     oobrisk <- t(as.data.frame(oobrisk))

Modified: pkg/mboostDevel/inst/NEWS.Rd
===================================================================
--- pkg/mboostDevel/inst/NEWS.Rd	2015-04-02 09:20:41 UTC (rev 841)
+++ pkg/mboostDevel/inst/NEWS.Rd	2015-04-02 09:20:44 UTC (rev 842)
@@ -1,12 +1,14 @@
 \name{NEWS}
 \title{News for Package 'mboost'}
 
-\section{Changes in mboost version 2.5-0 (2014-xx-yy)}{
+\section{Changes in mboost version 2.5-0 (2015-xx-yy)}{
   \subsection{User-visible changes}{
     \itemize{
       \item Strong speed-up of \code{stabsel.mboost}: We now only compute
       the model on each subsample until \code{q} variables were selected
       (or \code{mstop} is reached)
+      \item Better handling of errors in (single) folds of \code{cvrisk}:
+      results of folds without errors are used and a \code{warning} is issued.
     }
   }
   \subsection{Miscellaneous}{

Modified: pkg/mboostDevel/man/cvrisk.Rd
===================================================================
--- pkg/mboostDevel/man/cvrisk.Rd	2015-04-02 09:20:41 UTC (rev 841)
+++ pkg/mboostDevel/man/cvrisk.Rd	2015-04-02 09:20:44 UTC (rev 842)
@@ -10,7 +10,7 @@
 \method{cvrisk}{mboost}(object, folds = cv(model.weights(object)),
        grid = 1:mstop(object),
        papply = mclapply,
-       fun = NULL, corrected = TRUE, ...)
+       fun = NULL, corrected = TRUE, mc.preschedule = FALSE, ...)
 cv(weights, type = c("bootstrap", "kfold", "subsampling"),
    B = ifelse(type == "kfold", 10, 25), prob = 0.5, strata = NULL)
 }
@@ -35,7 +35,13 @@
   \item{corrected}{ if \code{TRUE}, the corrected cross-validation
     scheme of Verweij and van Houwelingen (1993) is used in case of Cox
     models. Otherwise, the naive standard cross-validation scheme is
-    used.}
+    used.
+  }
+  \item{mc.preschedule}{
+    preschedule tasks if are parallelized using \code{\link{mclapply}}
+    (default: \code{FALSE})? For details see \code{\link{mclapply}}.
+
+  }
   \item{weights}{ a numeric vector of weights for the model to be cross-validated.}
   \item{type}{ character argument for specifying the cross-validation
                method. Currently (stratified) bootstrap, k-fold cross-validation

Modified: pkg/mboostDevel/tests/regtest-inference.R
===================================================================
--- pkg/mboostDevel/tests/regtest-inference.R	2015-04-02 09:20:41 UTC (rev 841)
+++ pkg/mboostDevel/tests/regtest-inference.R	2015-04-02 09:20:44 UTC (rev 842)
@@ -1,5 +1,4 @@
 require("mboostDevel")
-attach(asNamespace("mboostDevel"))
 
 set.seed(1907)
 
@@ -20,3 +19,11 @@
 plot(confint.gam, which = 1)
 plot(confint.gam, which = 2)
 plot(confint.gam, which = 3)
+
+
+### check cvrisk (it should run even if a fold leads to an error)
+folds <- cv(model.weights(glm), type = "kfold")
+folds[1, 1] <- NA
+
+cvrisk(glm, folds = folds, papply = lapply)
+cvrisk(glm, folds = folds, papply = mclapply)