[Mboost-commits] r713 - in pkg/mboostDevel: . R

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

Author: thothorn
Date: 2013-04-22 12:04:55 +0200 (Mon, 22 Apr 2013)
New Revision: 713

Modified:
   pkg/mboostDevel/DESCRIPTION
   pkg/mboostDevel/NAMESPACE
   pkg/mboostDevel/R/bl.R
Log:
make sure bmono(..., constraint) does not interfere with bbs(..., constraint)

Modified: pkg/mboostDevel/DESCRIPTION
===================================================================
--- pkg/mboostDevel/DESCRIPTION	2013-04-20 16:48:07 UTC (rev 712)
+++ pkg/mboostDevel/DESCRIPTION	2013-04-22 10:04:55 UTC (rev 713)
@@ -16,9 +16,9 @@
   trees as base-learners for fitting generalized linear, additive
   and interaction models to potentially high-dimensional data.
 Depends: R (>= 2.14.0), methods, stats, parallel
-Imports: Matrix, survival, splines, lattice
-Suggests: party (>= 1.0-3), ipred, MASS, fields,
-  BayesX, gbm, mlbench, RColorBrewer, rpart (>= 4.0-3)
+Imports: Matrix, survival, splines, lattice, nnls
+Suggests: party (>= 1.0-3), ipred, MASS, fields, BayesX, gbm, mlbench,
+        RColorBrewer, rpart (>= 4.0-3)
 LazyData: yes
 License: GPL-2
-URL: http://r-forge.r-project.org/projects/mboost/
\ No newline at end of file
+URL: http://r-forge.r-project.org/projects/mboost/

Modified: pkg/mboostDevel/NAMESPACE
===================================================================
--- pkg/mboostDevel/NAMESPACE	2013-04-20 16:48:07 UTC (rev 712)
+++ pkg/mboostDevel/NAMESPACE	2013-04-22 10:04:55 UTC (rev 713)
@@ -6,6 +6,7 @@
 importFrom(survival, Surv, survfit)
 importFrom(splines, bs, splineDesign)
 importFrom(lattice, levelplot)
+importFrom(nnls, nnls)
 
 export(glmboost,
        gamboost,

Modified: pkg/mboostDevel/R/bl.R
===================================================================
--- pkg/mboostDevel/R/bl.R	2013-04-20 16:48:07 UTC (rev 712)
+++ pkg/mboostDevel/R/bl.R	2013-04-22 10:04:55 UTC (rev 713)
@@ -167,8 +167,7 @@
 ### hyper parameters for P-splines baselearner (including tensor product P-splines)
 hyper_bbs <- function(mf, vary, knots = 20, boundary.knots = NULL, degree = 3,
                       differences = 2, df = 4, lambda = NULL, center = FALSE,
-                      cyclic = FALSE, constraint = c("none", "increasing", "decreasing"),
-                      deriv = 0L) {
+                      cyclic = FALSE, constraint = "none", deriv = 0L) {
 
     knotf <- function(x, knots, boundary.knots) {
         if (is.null(boundary.knots))
@@ -198,13 +197,12 @@
         ret[[n]] <- knotf(mf[[n]], if (is.list(knots)) knots[[n]] else knots,
                           if (is.list(boundary.knots)) boundary.knots[[n]]
                           else boundary.knots)
-    constraint <- match.arg(constraint)
     if (cyclic & constraint != "none")
         stop("constraints not implemented for cyclic B-splines")
     stopifnot(is.numeric(deriv) & length(deriv) == 1)
     list(knots = ret, degree = degree, differences = differences,
          df = df, lambda = lambda, center = center, cyclic = cyclic,
-         constraint = constraint, deriv = deriv)
+         Ts_constraint = constraint, deriv = deriv)
 }
 
 ### model.matrix for P-splines baselearner (including tensor product P-splines)
@@ -216,7 +214,7 @@
                       knots = args$knots[[i]]$knots,
                       boundary.knots = args$knots[[i]]$boundary.knots,
                       degree = args$degree,
-                      constraint = args$constraint,
+                      Ts_constraint = args$Ts_constraint,
                       deriv = args$deriv)
         if (args$cyclic) {
             X <- cbs(mf[[i]],
@@ -300,7 +298,7 @@
         } else {
             K <- crossprod(K)
         }
-        if (!is.null(attr(X, "constraint"))) {
+        if (!is.null(attr(X, "Ts_constraint"))) {
             D <- attr(X, "D")
             K <- crossprod(D, K) %*% D
         }
@@ -556,7 +554,7 @@
                       args = hyper_bbs(mf, vary, knots = knots, boundary.knots =
                       boundary.knots, degree = degree, differences = differences,
                       df = df, lambda = lambda, center = center, cyclic = cyclic,
-                      constraint = constraint, deriv = deriv))
+                      constraint = match.arg(constraint), deriv = deriv))
     return(ret)
 }
 
@@ -602,7 +600,7 @@
     return(X)
 }
 
-bsplines <- function(x, knots, boundary.knots, degree, constraint, deriv){
+bsplines <- function(x, knots, boundary.knots, degree, Ts_constraint, deriv){
     nx <- names(x)
     x <- as.vector(x)
     ## handling of NAs
@@ -629,16 +627,16 @@
     ### constraints; experimental
     D <- diag(ncol(X))
     D[lower.tri(D)] <- 1
-    X <- switch(constraint, "none" = X,
+    X <- switch(Ts_constraint, "none" = X,
                             "increasing" = X %*% D,
                             "decreasing" = -X %*% D)
     ## add attributes
     attr(X, "degree") <- degree
     attr(X, "knots") <- knots
     attr(X, "boundary.knots") <- list(lower = bk_lower, upper = bk_upper)
-    if (constraint != "none")
-        attr(X, "constraint") <- constraint
-    if (constraint != "none")
+    if (Ts_constraint != "none")
+        attr(X, "Ts_constraint") <- Ts_constraint
+    if (Ts_constraint != "none")
         attr(X, "D") <- D
     if (deriv != 0)
         attr(X, "deriv") <- deriv
@@ -688,7 +686,7 @@
         if (is(X, "Matrix") && !extends(class(XtX), "dgeMatrix")) {
             XtXC <- Cholesky(forceSymmetric(XtX))
             mysolve <- function(y) {
-                if (is.null(attr(X, "constraint")))
+                if (is.null(attr(X, "Ts_constraint")))
                     return(solve(XtXC, crossprod(X, y)))  ## special solve routine from
                                                           ## package Matrix
                 ### non-negative LS only at the moment
@@ -701,7 +699,7 @@
                 XtX <- as(XtX, "matrix")
             }
             mysolve <- function(y) {
-                if (is.null(attr(X, "constraint")))
+                if (is.null(attr(X, "Ts_constraint")))
                     return(solve(XtX, crossprod(X, y), LINPACK = FALSE))
                 ### non-negative LS only at the moment
                 return(nnls1D(XtX, X, y))