[Mboost-commits] r717 - pkg/mboostDevel/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jun 27 14:29:31 CEST 2013
Author: thothorn
Date: 2013-06-27 14:29:31 +0200 (Thu, 27 Jun 2013)
New Revision: 717
Modified:
pkg/mboostDevel/R/bl.R
pkg/mboostDevel/R/helpers.R
Log:
make sure bbs and bmono don't interfere wrt constraints
Modified: pkg/mboostDevel/R/bl.R
===================================================================
--- pkg/mboostDevel/R/bl.R 2013-06-27 12:27:22 UTC (rev 716)
+++ pkg/mboostDevel/R/bl.R 2013-06-27 12:29:31 UTC (rev 717)
@@ -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))
Modified: pkg/mboostDevel/R/helpers.R
===================================================================
--- pkg/mboostDevel/R/helpers.R 2013-06-27 12:27:22 UTC (rev 716)
+++ pkg/mboostDevel/R/helpers.R 2013-06-27 12:29:31 UTC (rev 717)
@@ -124,7 +124,7 @@
nnls1D <- function(XtX, X, y) {
- my <- switch(attr(X, "constraint"), "increasing" = {
+ my <- switch(attr(X, "Ts_constraint"), "increasing" = {
### first column is intercept
stopifnot(max(abs(X[,1,drop = TRUE] - 1)) < sqrt(.Machine$double.eps))
min(y)
@@ -133,21 +133,20 @@
max(y)
})
y <- y - my
- stopifnot(require("nnls"))
cf <- nnls(XtX, crossprod(X, y))$x
- cf[1] <- cf[1] + switch(attr(X, "constraint"), "increasing" = my,
+ cf[1] <- cf[1] + switch(attr(X, "Ts_constraint"), "increasing" = my,
"decreasing" = -my)
cf
}
nnls2D <- function(X, XtX, Y) {
- constr <- which(c(!is.null(attr(X$X1, "constraint")),
- !is.null(attr(X$X2, "constraint"))))
+ constr <- which(c(!is.null(attr(X$X1, "Ts_constraint")),
+ !is.null(attr(X$X2, "Ts_constraint"))))
if (length(constr) == 2)
stop("only one dimension may be subject to constraints")
Xc <- paste("X", constr, sep = "")
- my <- switch(attr(X[[Xc]], "constraint"), "increasing" = {
+ my <- switch(attr(X[[Xc]], "Ts_constraint"), "increasing" = {
### first column is intercept
stopifnot(max(abs(X[[Xc]][,1,drop = TRUE] - 1)) < sqrt(.Machine$double.eps))
min(y)
@@ -158,13 +157,12 @@
Y <- Y - my
XWY <- as.vector(crossprod(X$X1, Y) %*% X$X2)
- stopifnot(require("nnls"))
cf <- nnls(XtX, matrix(as(XWY, "matrix"), ncol = 1))$x
cf <- matrix(cf, nrow = ncol(X$X1))
- if (constr == 1) cf[1,] <- cf[1,] + switch(attr(X[[Xc]], "constraint"),
+ if (constr == 1) cf[1,] <- cf[1,] + switch(attr(X[[Xc]], "Ts_constraint"),
"increasing" = my,
"decreasing" = -my)
- if (constr == 2) cf[,1] <- cf[,1] + switch(attr(X[[Xc]], "constraint"),
+ if (constr == 2) cf[,1] <- cf[,1] + switch(attr(X[[Xc]], "Ts_constraint"),
"increasing" = my,
"decreasing" = -my)
cf
More information about the Mboost-commits
mailing list