[Mboost-commits] r857 - in pkg/mboostPatch: R inst man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Aug 12 11:45:37 CEST 2015
Author: hofner
Date: 2015-08-12 11:45:37 +0200 (Wed, 12 Aug 2015)
New Revision: 857
Modified:
pkg/mboostPatch/R/bkronecker.R
pkg/mboostPatch/R/bl.R
pkg/mboostPatch/R/bmono.R
pkg/mboostPatch/R/bmrf.R
pkg/mboostPatch/R/bolscw.R
pkg/mboostPatch/R/mboost.R
pkg/mboostPatch/R/plot.R
pkg/mboostPatch/inst/NEWS.Rd
pkg/mboostPatch/man/baselearners.Rd
Log:
Prediction now also possible with newdata = list()
Modified: pkg/mboostPatch/R/bkronecker.R
===================================================================
--- pkg/mboostPatch/R/bkronecker.R 2015-07-30 15:32:47 UTC (rev 856)
+++ pkg/mboostPatch/R/bkronecker.R 2015-08-12 09:45:37 UTC (rev 857)
@@ -10,9 +10,22 @@
newX <- function(newdata = NULL) {
if (!is.null(newdata)) {
- stopifnot(all(names(newdata) == names(blg)))
- # stopifnot(all(class(newdata) == class(mf)))
- mf <- newdata[names(blg)]
+ nm <- names(blg)
+ if (!all(nm %in% names(newdata)))
+ stop(sQuote("newdata"),
+ " must contain all predictor variables,",
+ " which were used to specify the model.")
+ if (!class(newdata) %in% c("list", "data.frame"))
+ stop(sQuote("newdata"), " must be either a data.frame or a list")
+ if (any(duplicated(nm))) ## removes duplicates
+ nm <- unique(nm)
+ if (!all(sapply(newdata[nm], class) == sapply(mf, class)))
+ stop("Variables in ", sQuote("newdata"),
+ " must have the same classes as in the original data set")
+ ## subset data
+ mf <- newdata[nm]
+ if (is.list(mf))
+ mf <- as.data.frame(mf)
}
return(Xfun(mf, vary, args))
}
@@ -34,7 +47,7 @@
dpp <- function(weights) {
- if (!is.null(attr(X$X1, "deriv")) || !is.null(attr(X$X2, "deriv")))
+ if (!is.null(attr(X$X1, "deriv")) || !is.null(attr(X$X2, "deriv")))
stop("fitting of derivatives of B-splines not implemented")
W <- matrix(weights, nrow = n1, ncol = n2)
@@ -46,7 +59,7 @@
XtX <- array(XtX, c(c1, c1, c2, c2))
XtX <- mymatrix(aperm(XtX, c(1, 3, 2, 4)), nrow = c1 * c2)
- ### If lambda was given in both baselearners, we
+ ### If lambda was given in both baselearners, we
### directly multiply the marginal penalty matrices by lambda
### and then compute the total penalty as the kronecker sum.
### args$lambda is NA in this case and we don't compute
@@ -67,10 +80,10 @@
XtX <- XtX + K
### nnls
- constr <- (!is.null(attr(X$X1, "constraint"))) +
+ constr <- (!is.null(attr(X$X1, "constraint"))) +
(!is.null(attr(X$X2, "constraint")))
- if (constr == 2)
+ if (constr == 2)
stop("only one dimension may be subject to constraints")
constr <- constr > 0
@@ -135,8 +148,6 @@
cf <- lapply(bm, function(x) x$model)
if(!is.null(newdata)) {
index <- NULL
- nm <- names(blg)
- newdata <- newdata[nm]
X <- newX(newdata)$X
}
ncfprod <- function(b)
@@ -227,7 +238,7 @@
l1 <- args1$lambda
l2 <- args2$lambda
if (xor(is.null(l1), is.null(l2)))
- stop("lambda needs to be given in both baselearners combined with ",
+ stop("lambda needs to be given in both baselearners combined with ",
sQuote("%O%"))
if (!is.null(l1) && !is.null(l2)) {
### there is no common lambda!
Modified: pkg/mboostPatch/R/bl.R
===================================================================
--- pkg/mboostPatch/R/bl.R 2015-07-30 15:32:47 UTC (rev 856)
+++ pkg/mboostPatch/R/bl.R 2015-08-12 09:45:37 UTC (rev 857)
@@ -653,12 +653,22 @@
newX <- function(newdata = NULL) {
if (!is.null(newdata)) {
- stopifnot(all(names(blg) %in% names(newdata)))
- stopifnot(all(class(newdata) == class(mf)))
nm <- names(blg)
+ if (!all(nm %in% names(newdata)))
+ stop(sQuote("newdata"),
+ " must contain all predictor variables,",
+ " which were used to specify the model.")
+ if (!class(newdata) %in% c("list", "data.frame"))
+ stop(sQuote("newdata"), " must be either a data.frame or a list")
if (any(duplicated(nm))) ## removes duplicates
nm <- unique(nm)
- mf <- newdata[, nm, drop = FALSE]
+ if (!all(sapply(newdata[nm], class) == sapply(mf, class)))
+ stop("Variables in ", sQuote("newdata"),
+ " must have the same classes as in the original data set")
+ ## subset data
+ mf <- newdata[nm]
+ if (is.list(mf))
+ mf <- as.data.frame(mf)
}
return(Xfun(mf, vary, args))
}
@@ -728,7 +738,7 @@
hatvalues <- function() {
ret <- as.matrix(tcrossprod(X %*% solve(XtX), X * w))
if (is.null(index)) return(ret)
- return(ret[index,index])
+ return(ret[index, index])
}
### </FIXME>
@@ -738,19 +748,18 @@
### prepare for computing predictions
predict <- function(bm, newdata = NULL, aggregate = c("sum", "cumsum", "none")) {
cf <- sapply(bm, coef)
- if (!is.matrix(cf)) cf <- matrix(cf, nrow = 1)
+ if (!is.matrix(cf))
+ cf <- matrix(cf, nrow = 1)
if(!is.null(newdata)) {
index <- NULL
- nm <- names(blg)
- if (any(duplicated(nm))) ## removes duplicates
- nm <- unique(nm)
- newdata <- newdata[,nm, drop = FALSE]
- ### option
- if (nrow(newdata) > options("mboost_indexmin")[[1]]) {
+ ## Use sparse data represenation if data set is huge
+ ## and a data.frame
+ if (is.data.frame(newdata) && nrow(newdata) > options("mboost_indexmin")[[1]]) {
index <- get_index(newdata)
- newdata <- newdata[index[[1]],,drop = FALSE]
+ newdata <- newdata[index[[1]], , drop = FALSE]
index <- index[[2]]
}
+
X <- newX(newdata)$X
}
aggregate <- match.arg(aggregate)
@@ -761,8 +770,9 @@
PACKAGE = "mboost"), "matrix")
},
"none" = as(X %*% cf, "matrix"))
- if (is.null(index)) return(pr[,,drop = FALSE])
- return(pr[index,,drop = FALSE])
+ if (is.null(index))
+ return(pr[ , , drop = FALSE])
+ return(pr[index, ,drop = FALSE])
}
ret <- list(fit = fit, hatvalues = hatvalues,
Modified: pkg/mboostPatch/R/bmono.R
===================================================================
--- pkg/mboostPatch/R/bmono.R 2015-07-30 15:32:47 UTC (rev 856)
+++ pkg/mboostPatch/R/bmono.R 2015-08-12 09:45:37 UTC (rev 857)
@@ -160,9 +160,22 @@
newX <- function(newdata = NULL) {
if (!is.null(newdata)) {
- stopifnot(all(names(newdata) == names(blg)))
- stopifnot(all(class(newdata) == class(mf)))
- mf <- newdata[,names(blg),drop = FALSE]
+ nm <- names(blg)
+ if (!all(nm %in% names(newdata)))
+ stop(sQuote("newdata"),
+ " must contain all predictor variables,",
+ " which were used to specify the model.")
+ if (!class(newdata) %in% c("list", "data.frame"))
+ stop(sQuote("newdata"), " must be either a data.frame or a list")
+ if (any(duplicated(nm))) ## removes duplicates
+ nm <- unique(nm)
+ if (!all(sapply(newdata[nm], class) == sapply(mf, class)))
+ stop("Variables in ", sQuote("newdata"),
+ " must have the same classes as in the original data set")
+ ## subset data
+ mf <- newdata[nm]
+ if (is.list(mf))
+ mf <- as.data.frame(mf)
}
return(Xfun(mf, vary, args))
}
@@ -338,12 +351,11 @@
if (!is.matrix(cf)) cf <- matrix(cf, nrow = 1)
if(!is.null(newdata)) {
index <- NULL
- nm <- names(blg)
- newdata <- newdata[,nm, drop = FALSE]
- ### option
- if (nrow(newdata) > options("mboost_indexmin")[[1]]) {
+ ## Use sparse data represenation if data set is huge
+ ## and a data.frame
+ if (is.data.frame(newdata) && nrow(newdata) > options("mboost_indexmin")[[1]]) {
index <- get_index(newdata)
- newdata <- newdata[index[[1]],,drop = FALSE]
+ newdata <- newdata[index[[1]], , drop = FALSE]
index <- index[[2]]
}
X <- newX(newdata)$X
@@ -356,8 +368,9 @@
PACKAGE = "mboost"), "matrix")
},
"none" = as(X %*% cf, "matrix"))
- if (is.null(index)) return(pr[,,drop = FALSE])
- return(pr[index,,drop = FALSE])
+ if (is.null(index))
+ return(pr[, , drop = FALSE])
+ return(pr[index, , drop = FALSE])
}
ret <- list(fit = fit, hatvalues = hatvalues,
Modified: pkg/mboostPatch/R/bmrf.R
===================================================================
--- pkg/mboostPatch/R/bmrf.R 2015-07-30 15:32:47 UTC (rev 856)
+++ pkg/mboostPatch/R/bmrf.R 2015-08-12 09:45:37 UTC (rev 857)
@@ -1,7 +1,5 @@
-bmrf <-
-function (..., by = NULL, index = NULL, bnd = NULL, df = 4, lambda = NULL,
- center = FALSE)
-{
+bmrf <- function (..., by = NULL, index = NULL, bnd = NULL, df = 4,
+ lambda = NULL, center = FALSE) {
if (!requireNamespace("BayesX"))
stop("cannot load ", sQuote("BayesX"))
Modified: pkg/mboostPatch/R/bolscw.R
===================================================================
--- pkg/mboostPatch/R/bolscw.R 2015-07-30 15:32:47 UTC (rev 856)
+++ pkg/mboostPatch/R/bolscw.R 2015-08-12 09:45:37 UTC (rev 857)
@@ -57,7 +57,7 @@
return(ret)
}
- predict <- function(bm, newdata = NULL,
+ predict <- function(bm, newdata = NULL,
aggregate = c("sum", "cumsum", "none")) {
aggregate <- match.arg(aggregate)
@@ -97,7 +97,7 @@
return(X %*% cf)
}
- ret <- list(fit = fit, predict = predict, Xnames = colnames(X),
+ ret <- list(fit = fit, predict = predict, Xnames = colnames(X),
MPinv = function() {
if (is.null(MPinvS)) MPinvS <<- t(X * weights) / sxtx
return(MPinvS / sxtx)
Modified: pkg/mboostPatch/R/mboost.R
===================================================================
--- pkg/mboostPatch/R/mboost.R 2015-07-30 15:32:47 UTC (rev 856)
+++ pkg/mboostPatch/R/mboost.R 2015-08-12 09:45:37 UTC (rev 857)
@@ -589,9 +589,9 @@
### this function will be used for predictions later
newX <- function(newdata) {
mf <- model.frame(delete.response(attr(mf, "terms")),
- data = newdata, na.action = na.pass)
- X <- model.matrix(delete.response(attr(mf, "terms")), data = mf,
- contrasts.arg = contrasts.arg)
+ data = newdata, na.action = na.pass)
+ X <- model.matrix(delete.response(attr(mf, "terms")),
+ data = mf, contrasts.arg = contrasts.arg)
scale(X, center = cm, scale = FALSE)
}
Modified: pkg/mboostPatch/R/plot.R
===================================================================
--- pkg/mboostPatch/R/plot.R 2015-07-30 15:32:47 UTC (rev 856)
+++ pkg/mboostPatch/R/plot.R 2015-08-12 09:45:37 UTC (rev 857)
@@ -41,8 +41,13 @@
data <- model.frame(x, which = w)[[1]]
get_vary <- x$baselearner[[w]]$get_vary
vary <- ""
- if (!is.null(get_vary)) vary <- get_vary()
- if (!is.null(newdata)) data <- newdata[, colnames(data), drop = FALSE]
+ if (!is.null(get_vary))
+ vary <- get_vary()
+ if (!is.null(newdata)) {
+ data <- newdata[colnames(data)]
+ if (is.list(data))
+ data <- as.data.frame(data)
+ }
if (vary != "") {
v <- data[[vary]]
if (is.factor(v)) v <- factor(levels(v)[-1], levels = levels(v))
Modified: pkg/mboostPatch/inst/NEWS.Rd
===================================================================
--- pkg/mboostPatch/inst/NEWS.Rd 2015-07-30 15:32:47 UTC (rev 856)
+++ pkg/mboostPatch/inst/NEWS.Rd 2015-08-12 09:45:37 UTC (rev 857)
@@ -6,7 +6,7 @@
\itemize{
\item Added documentation for \code{plot.mboost} function and moved
documentation of \code{plot.glmboost} to the same help page.
- Resolves issue \href{https://github.com/hofnerb/mboost/issues/11}{#11}.
+ Resolves issue \href{https://github.com/hofnerb/mboost/issues/14}{#14}.
}
}
\subsection{Miscellaneous}{
@@ -29,6 +29,11 @@
\item Truncate output of complete data structure when model is
printed. Resolves issue
\href{https://github.com/hofnerb/mboost/issues/11}{#11}.
+ \item Prediction now also possible with \code{newdata = list()}.
+ Resolves issue
+ \href{https://github.com/hofnerb/mboost/issues/15}{#15}.
+ \item Adhere to CRAN policies regarding import of base packages
+ (closes \href{https://github.com/hofnerb/mboost/issues/9}{#9}).
}
}
}
Modified: pkg/mboostPatch/man/baselearners.Rd
===================================================================
--- pkg/mboostPatch/man/baselearners.Rd 2015-07-30 15:32:47 UTC (rev 856)
+++ pkg/mboostPatch/man/baselearners.Rd 2015-08-12 09:45:37 UTC (rev 857)
@@ -1,4 +1,5 @@
\name{baselearners}
+\alias{baselearners}
\alias{bols}
\alias{bbs}
\alias{bspatial}
More information about the Mboost-commits
mailing list