[Mboost-commits] r714 - pkg/mboostDevel/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Apr 23 14:34:23 CEST 2013
Author: thothorn
Date: 2013-04-23 14:34:23 +0200 (Tue, 23 Apr 2013)
New Revision: 714
Modified:
pkg/mboostDevel/R/bl.R
pkg/mboostDevel/R/helpers.R
Log:
make sure increasing works the same way
Modified: pkg/mboostDevel/R/bl.R
===================================================================
--- pkg/mboostDevel/R/bl.R 2013-04-22 10:04:55 UTC (rev 713)
+++ pkg/mboostDevel/R/bl.R 2013-04-23 12:34:23 UTC (rev 714)
@@ -167,7 +167,8 @@
### 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 = "none", deriv = 0L) {
+ cyclic = FALSE, constraint = c("none", "increasing", "decreasing"),
+ deriv = 0L) {
knotf <- function(x, knots, boundary.knots) {
if (is.null(boundary.knots))
@@ -197,12 +198,13 @@
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,
- Ts_constraint = constraint, deriv = deriv)
+ constraint = constraint, deriv = deriv)
}
### model.matrix for P-splines baselearner (including tensor product P-splines)
@@ -214,7 +216,7 @@
knots = args$knots[[i]]$knots,
boundary.knots = args$knots[[i]]$boundary.knots,
degree = args$degree,
- Ts_constraint = args$Ts_constraint,
+ constraint = args$constraint,
deriv = args$deriv)
if (args$cyclic) {
X <- cbs(mf[[i]],
@@ -298,7 +300,7 @@
} else {
K <- crossprod(K)
}
- if (!is.null(attr(X, "Ts_constraint"))) {
+ if (!is.null(attr(X, "constraint"))) {
D <- attr(X, "D")
K <- crossprod(D, K) %*% D
}
@@ -554,7 +556,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 = match.arg(constraint), deriv = deriv))
+ constraint = constraint, deriv = deriv))
return(ret)
}
@@ -600,7 +602,7 @@
return(X)
}
-bsplines <- function(x, knots, boundary.knots, degree, Ts_constraint, deriv){
+bsplines <- function(x, knots, boundary.knots, degree, constraint, deriv){
nx <- names(x)
x <- as.vector(x)
## handling of NAs
@@ -627,16 +629,16 @@
### constraints; experimental
D <- diag(ncol(X))
D[lower.tri(D)] <- 1
- X <- switch(Ts_constraint, "none" = X,
+ X <- switch(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 (Ts_constraint != "none")
- attr(X, "Ts_constraint") <- Ts_constraint
- if (Ts_constraint != "none")
+ if (constraint != "none")
+ attr(X, "constraint") <- constraint
+ if (constraint != "none")
attr(X, "D") <- D
if (deriv != 0)
attr(X, "deriv") <- deriv
@@ -686,7 +688,7 @@
if (is(X, "Matrix") && !extends(class(XtX), "dgeMatrix")) {
XtXC <- Cholesky(forceSymmetric(XtX))
mysolve <- function(y) {
- if (is.null(attr(X, "Ts_constraint")))
+ if (is.null(attr(X, "constraint")))
return(solve(XtXC, crossprod(X, y))) ## special solve routine from
## package Matrix
### non-negative LS only at the moment
@@ -699,7 +701,7 @@
XtX <- as(XtX, "matrix")
}
mysolve <- function(y) {
- if (is.null(attr(X, "Ts_constraint")))
+ if (is.null(attr(X, "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-04-22 10:04:55 UTC (rev 713)
+++ pkg/mboostDevel/R/helpers.R 2013-04-23 12:34:23 UTC (rev 714)
@@ -124,15 +124,19 @@
nnls1D <- function(XtX, X, y) {
- my <- min(y)
- if (my < 0) {
+ my <- switch(attr(X, "constraint"), "increasing" = {
### first column is intercept
- stopifnot(max(abs(X[,1] - 1)) < sqrt(.Machine$double.eps))
- y <- y - my
- }
+ stopifnot(max(abs(X[,1,drop = TRUE] - 1)) < sqrt(.Machine$double.eps))
+ min(y)
+ }, "decreasing" = {
+ stopifnot(max(abs(X[,1,drop = TRUE] + 1)) < sqrt(.Machine$double.eps))
+ max(y)
+ })
+ y <- y - my
stopifnot(require("nnls"))
cf <- nnls(XtX, crossprod(X, y))$x
- if (my < 0) cf[1] <- cf[1] + my
+ cf[1] <- cf[1] + switch(attr(X, "constraint"), "increasing" = my,
+ "decreasing" = -my)
cf
}
@@ -142,21 +146,26 @@
!is.null(attr(X$X2, "constraint"))))
if (length(constr) == 2)
stop("only one dimension may be subject to constraints")
- my <- min(Y)
- if (my < 0) {
- ### first column is intercept
- stopifnot(max(abs(X[[paste("X", constr, sep = "")]][,1] - 1)) <
- sqrt(.Machine$double.eps))
- Y <- Y - my
- }
+ Xc <- paste("X", constr, sep = "")
+ my <- switch(attr(X[[Xc]], "constraint"), "increasing" = {
+ ### first column is intercept
+ stopifnot(max(abs(X[[Xc]][,1,drop = TRUE] - 1)) < sqrt(.Machine$double.eps))
+ min(y)
+ }, "decreasing" = {
+ stopifnot(max(abs(X[[Xc]][,1,drop = TRUE] + 1)) < sqrt(.Machine$double.eps))
+ max(y)
+ })
+ 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 (my < 0) {
- if (constr == 1) cf[1,] <- cf[1,] + my
- if (constr == 2) cf[,1] <- cf[,1] + my
- }
+ if (constr == 1) cf[1,] <- cf[1,] + switch(attr(X[[Xc]], "constraint"),
+ "increasing" = my,
+ "decreasing" = -my)
+ if (constr == 2) cf[,1] <- cf[,1] + switch(attr(X[[Xc]], "constraint"),
+ "increasing" = my,
+ "decreasing" = -my)
cf
}
More information about the Mboost-commits
mailing list