[Mboost-commits] r776 - in pkg: mboostDevel/R mboostDevel/vignettes mboostPatch/R mboostPatch/inst mboostPatch/vignettes

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Thu Jul 3 17:45:02 CEST 2014


Author: hofner
Date: 2014-07-03 17:45:02 +0200 (Thu, 03 Jul 2014)
New Revision: 776

Modified:
   pkg/mboostDevel/R/mboost.R
   pkg/mboostDevel/vignettes/mboost_tutorial.Rnw
   pkg/mboostPatch/R/mboost.R
   pkg/mboostPatch/inst/CHANGES
   pkg/mboostPatch/vignettes/mboost_tutorial.Rnw
Log:
- Bugfix: update() didn't work correlty for glmboost models


Modified: pkg/mboostDevel/R/mboost.R
===================================================================
--- pkg/mboostDevel/R/mboost.R	2014-07-03 13:41:21 UTC (rev 775)
+++ pkg/mboostDevel/R/mboost.R	2014-07-03 15:45:02 UTC (rev 776)
@@ -604,6 +604,35 @@
             warning("Argument ", sQuote("which"), " is ignored")
         mf
     }
+    ### save standard update function for re-use
+    update <- ret$update
+    ### needs a specialized update function as well
+    ret$update <- function(weights = NULL, oobweights = NULL, risk = "oobag") {
+        ## call standard update function
+        res <- update(weights = weights, oobweights = oobweights, risk = risk)
+        ## now re-set all special arguments
+        res$newX <- newX
+        res$assign <- assign
+        res$center <- cm
+        res$call <- cl
+        ### need specialized method (hatvalues etc. anyway)
+        res$hatvalues <- function() {
+            H <- vector(mode = "list", length = ncol(X))
+            MPinv <- res$basemodel[[1]]$MPinv()
+            for (j in unique(res$xselect()))
+                H[[j]] <- (X[,j] %*% MPinv[j, ,drop = FALSE]) * control$nu
+            H
+        }
+        res$rownames <- rownames(mf)
+        ### specialized method for model.frame
+        res$model.frame <- function(which = NULL) {
+            if (!is.null(which))
+                warning("Argument ", sQuote("which"), " is ignored")
+            mf
+        }
+        class(res) <- c("glmboost", "mboost")
+        res
+    }
     class(ret) <- c("glmboost", "mboost")
     return(ret)
 }
@@ -670,8 +699,37 @@
     ret$model.frame <- function(which = NULL) {
         if (!is.null(which))
             warning("Argument ", sQuote("which"), " is ignored")
-        mf
+        X
     }
+    ### save standard update function for re-use
+    update <- ret$update
+    ### needs a specialized update function as well
+    ret$update <- function(weights = NULL, oobweights = NULL, risk = "oobag") {
+        ## call standard update function
+        res <- update(weights = weights, oobweights = oobweights, risk = risk)
+        ## now re-set all special arguments
+        ret$newX <- newX
+        res$assign <- assign
+        res$center <- cm
+        res$call <- match.call()
+        ### need specialized method (hatvalues etc. anyway)
+        res$hatvalues <- function() {
+            H <- vector(mode = "list", length = ncol(X))
+            MPinv <- res$basemodel[[1]]$MPinv()
+            for (j in unique(res$xselect()))
+                H[[j]] <- (X[,j] %*% MPinv[j, ,drop = FALSE]) * control$nu
+            H
+        }
+        res$rownames <- rownames(X)
+        ### specialized method for model.frame
+        res$model.frame <- function(which = NULL) {
+            if (!is.null(which))
+                warning("Argument ", sQuote("which"), " is ignored")
+            X
+        }
+        class(res) <- c("glmboost", "mboost")
+        res
+    }
     class(ret) <- c("glmboost", "mboost")
     return(ret)
 }

Modified: pkg/mboostDevel/vignettes/mboost_tutorial.Rnw
===================================================================
--- pkg/mboostDevel/vignettes/mboost_tutorial.Rnw	2014-07-03 13:41:21 UTC (rev 775)
+++ pkg/mboostDevel/vignettes/mboost_tutorial.Rnw	2014-07-03 15:45:02 UTC (rev 776)
@@ -127,8 +127,8 @@
   DOI \href{http://dx.doi.org/10.1007/s00180-012-0382-5}{10.1007/s00180-012-0382-5}.\\
   The final publication is available at \url{http://link.springer.com}.\\[2em]
   Changes to the results in the original manuscript are due to changes in some
-  defaults of mboost (most notably the definition of degrees of freedom has
-  changed in mboost 2.2-0). See NEWS for details.
+  defaults of \textbf{mboost} (most notably the definition of degrees of freedom
+  has changed in \textbf{mboost} 2.2-0). See NEWS for details.
 \end{center}
 \bigskip
 
@@ -493,7 +493,7 @@
 body fat of women based on available anthropometric measurements. Observations
 of 71 German women are available with the data set \R{bodyfat} \citep{garcia}
 included in \textbf{mboost}. We first load the package and the data set%
-\footnote{The data set \R{bodyfat} has been moved to the package \pkg{TH.data}.}.
+\footnote{The data set \R{bodyfat} has been moved to the package \textbf{TH.data}.}.
 
 <<setup, echo = true, results = hide>>=
 library("mboostDevel")                         ## load package

Modified: pkg/mboostPatch/R/mboost.R
===================================================================
--- pkg/mboostPatch/R/mboost.R	2014-07-03 13:41:21 UTC (rev 775)
+++ pkg/mboostPatch/R/mboost.R	2014-07-03 15:45:02 UTC (rev 776)
@@ -604,6 +604,35 @@
             warning("Argument ", sQuote("which"), " is ignored")
         mf
     }
+    ### save standard update function for re-use
+    update <- ret$update
+    ### needs a specialized update function as well
+    ret$update <- function(weights = NULL, oobweights = NULL, risk = "oobag") {
+        ## call standard update function
+        res <- update(weights = weights, oobweights = oobweights, risk = risk)
+        ## now re-set all special arguments
+        res$newX <- newX
+        res$assign <- assign
+        res$center <- cm
+        res$call <- cl
+        ### need specialized method (hatvalues etc. anyway)
+        res$hatvalues <- function() {
+            H <- vector(mode = "list", length = ncol(X))
+            MPinv <- res$basemodel[[1]]$MPinv()
+            for (j in unique(res$xselect()))
+                H[[j]] <- (X[,j] %*% MPinv[j, ,drop = FALSE]) * control$nu
+            H
+        }
+        res$rownames <- rownames(mf)
+        ### specialized method for model.frame
+        res$model.frame <- function(which = NULL) {
+            if (!is.null(which))
+                warning("Argument ", sQuote("which"), " is ignored")
+            mf
+        }
+        class(res) <- c("glmboost", "mboost")
+        res
+    }
     class(ret) <- c("glmboost", "mboost")
     return(ret)
 }
@@ -670,8 +699,37 @@
     ret$model.frame <- function(which = NULL) {
         if (!is.null(which))
             warning("Argument ", sQuote("which"), " is ignored")
-        mf
+        X
     }
+    ### save standard update function for re-use
+    update <- ret$update
+    ### needs a specialized update function as well
+    ret$update <- function(weights = NULL, oobweights = NULL, risk = "oobag") {
+        ## call standard update function
+        res <- update(weights = weights, oobweights = oobweights, risk = risk)
+        ## now re-set all special arguments
+        ret$newX <- newX
+        res$assign <- assign
+        res$center <- cm
+        res$call <- match.call()
+        ### need specialized method (hatvalues etc. anyway)
+        res$hatvalues <- function() {
+            H <- vector(mode = "list", length = ncol(X))
+            MPinv <- res$basemodel[[1]]$MPinv()
+            for (j in unique(res$xselect()))
+                H[[j]] <- (X[,j] %*% MPinv[j, ,drop = FALSE]) * control$nu
+            H
+        }
+        res$rownames <- rownames(X)
+        ### specialized method for model.frame
+        res$model.frame <- function(which = NULL) {
+            if (!is.null(which))
+                warning("Argument ", sQuote("which"), " is ignored")
+            X
+        }
+        class(res) <- c("glmboost", "mboost")
+        res
+    }
     class(ret) <- c("glmboost", "mboost")
     return(ret)
 }

Modified: pkg/mboostPatch/inst/CHANGES
===================================================================
--- pkg/mboostPatch/inst/CHANGES	2014-07-03 13:41:21 UTC (rev 775)
+++ pkg/mboostPatch/inst/CHANGES	2014-07-03 15:45:02 UTC (rev 776)
@@ -2,7 +2,9 @@
 
   o  changed vignette mboost_tutorial to reflect latest changes in mboost.
 
-  o  Bugfix: model.frame() was broken for glmboost models
+  o  Bugfixes: 
+     - glmboost()$model.frame() was broken
+     - glmboost()$update() was broken
 
                 CHANGES in `mboost' VERSION 2.3-0 (2014-06-26, r771)
 

Modified: pkg/mboostPatch/vignettes/mboost_tutorial.Rnw
===================================================================
--- pkg/mboostPatch/vignettes/mboost_tutorial.Rnw	2014-07-03 13:41:21 UTC (rev 775)
+++ pkg/mboostPatch/vignettes/mboost_tutorial.Rnw	2014-07-03 15:45:02 UTC (rev 776)
@@ -127,8 +127,8 @@
   DOI \href{http://dx.doi.org/10.1007/s00180-012-0382-5}{10.1007/s00180-012-0382-5}.\\
   The final publication is available at \url{http://link.springer.com}.\\[2em]
   Changes to the results in the original manuscript are due to changes in some
-  defaults of mboost (most notably the definition of degrees of freedom has
-  changed in mboost 2.2-0). See NEWS for details.
+  defaults of \textbf{mboost} (most notably the definition of degrees of freedom
+  has changed in \textbf{mboost} 2.2-0). See NEWS for details.
 \end{center}
 \bigskip
 
@@ -493,7 +493,7 @@
 body fat of women based on available anthropometric measurements. Observations
 of 71 German women are available with the data set \R{bodyfat} \citep{garcia}
 included in \textbf{mboost}. We first load the package and the data set%
-\footnote{The data set \R{bodyfat} has been moved to the package \pkg{TH.data}.}.
+\footnote{The data set \R{bodyfat} has been moved to the package \textbf{TH.data}.}.
 
 <<setup, echo = true, results = hide>>=
 library("mboost")                         ## load package



More information about the Mboost-commits mailing list