[Mboost-commits] r862 - / pkg/mboostPatch pkg/mboostPatch/R pkg/mboostPatch/inst pkg/mboostPatch/man pkg/mboostPatch/tests pkg/mboostPatch/tests/Examples pkg/mboostPatch/vignettes
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Aug 18 18:13:34 CEST 2015
Author: hofner
Date: 2015-08-18 18:13:34 +0200 (Tue, 18 Aug 2015)
New Revision: 862
Modified:
.travis.yml
README.md
checks.R
pkg/mboostPatch/DESCRIPTION
pkg/mboostPatch/R/AAA.R
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/crossvalidation.R
pkg/mboostPatch/R/helpers.R
pkg/mboostPatch/R/plot.R
pkg/mboostPatch/inst/NEWS.Rd
pkg/mboostPatch/man/Family.Rd
pkg/mboostPatch/man/baselearners.Rd
pkg/mboostPatch/man/confint.Rd
pkg/mboostPatch/man/cvrisk.Rd
pkg/mboostPatch/man/mboost.Rd
pkg/mboostPatch/man/mboost_package.Rd
pkg/mboostPatch/man/stabsel.Rd
pkg/mboostPatch/tests/Examples/mboost-Ex.Rout.save
pkg/mboostPatch/tests/birds_Biometrics.Rout.save
pkg/mboostPatch/tests/bugfixes.Rout.save
pkg/mboostPatch/tests/regtest-baselearner.R
pkg/mboostPatch/tests/regtest-baselearner.Rout.save
pkg/mboostPatch/tests/regtest-blackboost.Rout.save
pkg/mboostPatch/tests/regtest-family.Rout.save
pkg/mboostPatch/tests/regtest-gamboost.Rout.save
pkg/mboostPatch/tests/regtest-glmboost.Rout.save
pkg/mboostPatch/tests/regtest-hatmatrix.Rout.save
pkg/mboostPatch/tests/regtest-inference.R
pkg/mboostPatch/tests/regtest-inference.Rout.save
pkg/mboostPatch/vignettes/SurvivalEnsembles.Rout.save
pkg/mboostPatch/vignettes/mboost.Rout.save
pkg/mboostPatch/vignettes/mboost_illustrations.Rout.save
pkg/mboostPatch/vignettes/mboost_tutorial.Rout.save
svn_release.txt
Log:
release mboost 2.5-0
Modified: .travis.yml
===================================================================
--- .travis.yml 2015-08-14 13:29:22 UTC (rev 861)
+++ .travis.yml 2015-08-18 16:13:34 UTC (rev 862)
@@ -8,7 +8,7 @@
before_install:
- sudo apt-get update -qq
- sudo apt-get install latex-xcolor
- - cd pkg/mboostDevel
+ - cd pkg/mboostPatch
r_github_packages:
- hofnerb/stabs
Modified: README.md
===================================================================
--- README.md 2015-08-14 13:29:22 UTC (rev 861)
+++ README.md 2015-08-18 16:13:34 UTC (rev 862)
@@ -61,3 +61,5 @@
However, currently these builds often don't succeed and furthermore are only available
for recent versions of R.
+[inst]: inst
+
Modified: checks.R
===================================================================
--- checks.R 2015-08-14 13:29:22 UTC (rev 861)
+++ checks.R 2015-08-18 16:13:34 UTC (rev 862)
@@ -34,6 +34,8 @@
summarize_check_packages_in_dir_results(ddir, all = TRUE)
summarize_check_packages_in_dir_timings(ddir, all = TRUE)
- tools:::check_packages_in_dir_changes(ddir, cdir, outputs = TRUE, sources = TRUE)
+ check_packages_in_dir_changes(ddir, cdir, outputs = TRUE, sources = TRUE)
# setwd(odir)
}
+
+package_dependencies("mboost", available.packages(), reverse = TRUE)
Modified: pkg/mboostPatch/DESCRIPTION
===================================================================
--- pkg/mboostPatch/DESCRIPTION 2015-08-14 13:29:22 UTC (rev 861)
+++ pkg/mboostPatch/DESCRIPTION 2015-08-18 16:13:34 UTC (rev 862)
@@ -1,7 +1,7 @@
Package: mboost
Title: Model-Based Boosting
-Version: 2.4-3
-Date: 2015-08-12
+Version: 2.5-0
+Date: 2015-08-13
Authors at R: c(person("Torsten", "Hothorn", role = c("aut", "cre"),
email = "Torsten.Hothorn at R-project.org"),
person("Peter", "Buehlmann", role = "aut"),
Modified: pkg/mboostPatch/R/AAA.R
===================================================================
--- pkg/mboostPatch/R/AAA.R 2015-08-14 13:29:22 UTC (rev 861)
+++ pkg/mboostPatch/R/AAA.R 2015-08-18 16:13:34 UTC (rev 862)
@@ -1,28 +1,3 @@
-
-#.onAttach <- function(libname, pkgname) {
-#
-# sup <- file.path(libname, pkgname, "startup.txt")
-# if (file.exists(sup) || !interactive()) return(TRUE)
-# if (!suppressWarnings(file.create(sup))) return(TRUE)
-# file.remove(sup)
-# version <- packageDescription(pkg = pkgname)$Version
-# txt <- c("\n",
-# paste(" Welcome to ", sQuote("mboost"),
-# " version ", version, "!", sep = ""),
-# "\n",
-# "The user-interface changed in some places.",
-# paste("Most important, subsetting an", sQuote("mboost"),
-# "object modifies this object now."),
-# "Please read the NEWS file, consult the documentation and have fun!",
-# "\n",
-# "Would you like to see this message on startup again?")
-# packageStartupMessage(txt)
-# choice <- menu(c("Please, no!", "Yes, please!"))
-# if (choice == 2) return(TRUE)
-# file.create(sup)
-# return(TRUE)
-#}
-
.onAttach <- function(libname, pkgname) {
## get package version
@@ -44,7 +19,9 @@
mboost_dftraceS = FALSE, ### df = trace(S) or df = trace(2 S - StS)
mboost_lambdaMax = 1e+15,### maximum value for lambda as used in df2lambda
mboost_Xmonotone = FALSE,### don't force monotonicity in %X%
- mboost_eps = 10e-10) ### factor for dmat in df2lambda
+ mboost_eps = 10e-10, ### factor for dmat in df2lambda
+ mboost_check_df2lambda = TRUE) ### check if max(abs(X)) > 10 in df2lambda
+ ### as this might take a while experts can skip this check
}
.onUnload <- function(libpath) {
Modified: pkg/mboostPatch/R/bkronecker.R
===================================================================
--- pkg/mboostPatch/R/bkronecker.R 2015-08-14 13:29:22 UTC (rev 861)
+++ pkg/mboostPatch/R/bkronecker.R 2015-08-18 16:13:34 UTC (rev 862)
@@ -8,25 +8,12 @@
index <- blg$get_index()
vary <- blg$get_vary()
- newX <- function(newdata = NULL) {
+ newX <- function(newdata = NULL, prediction = FALSE) {
if (!is.null(newdata)) {
- 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)
+ mf <- check_newdata(newdata, blg, mf, to.data.frame = FALSE)
}
+ ## this argument is currently only used in X_bbs --> bsplines
+ args$prediction <- prediction
return(Xfun(mf, vary, args))
}
X <- newX()
@@ -67,7 +54,7 @@
if (is.null(args$lambda)) {
### <FIXME>: is there a better way to feed XtX into lambdadf?
- lambdadf <- df2lambda(matrix(0, ncol = ncol(X$X1) + ncol(X$X2)),
+ lambdadf <- df2lambda(X = diag(rankMatrix(X$X1, method = 'qr') * rankMatrix(X$X2, method = 'qr')),
df = args$df, lambda = args$lambda,
dmat = K, weights = weights, XtX = XtX)
### </FIXME>
@@ -148,7 +135,7 @@
cf <- lapply(bm, function(x) x$model)
if(!is.null(newdata)) {
index <- NULL
- X <- newX(newdata)$X
+ X <- newX(newdata, prediction = TRUE)$X
}
ncfprod <- function(b)
as.vector(as(tcrossprod(X$X1 %*% b, X$X2), "matrix"))
Modified: pkg/mboostPatch/R/bl.R
===================================================================
--- pkg/mboostPatch/R/bl.R 2015-08-14 13:29:22 UTC (rev 861)
+++ pkg/mboostPatch/R/bl.R 2015-08-18 16:13:34 UTC (rev 862)
@@ -6,13 +6,24 @@
stopifnot(xor(is.null(df), is.null(lambda)))
- if (!is.null(df))
- if (df >= ncol(X)) return(c(df = df, lambda = 0))
+ if (!is.null(df)) {
+ rank_X <- rankMatrix(X, method = 'qr')
+ if (df >= rank_X) {
+ if (df > rank_X)
+ warning(sQuote("df"),
+ " too large:\n Degrees of freedom cannot be larger",
+ " than the rank of the design matrix.\n",
+ " Unpenalized base-learner with df = ",
+ rank_X, " used. Re-consider model specification.")
+ return(c(df = df, lambda = 0))
+ }
+ }
if (!is.null(lambda))
- if (lambda == 0) return(c(df = ncol(X), lambda = 0))
+ if (lambda == 0)
+ return(c(df = rankMatrix(X), lambda = 0))
## check for possible instability
- if (max(abs(X)) > 10)
+ if (options("mboost_check_df2lambda")[[1]] && max(abs(X)) > 10)
warning("Some absolute values in design matrix are greater 10. Hence, ",
sQuote("df2lambda"), " might be numerically instable.\n ",
"See documentation of argument ", sQuote("by"),
@@ -32,9 +43,15 @@
dmat <- diag(ncol(XtX))
}
A <- XtX + dmat * options("mboost_eps")[[1]]
+ ## make sure that A is also numerically symmetric
+ if (is(A, "Matrix"))
+ A <- forceSymmetric(A)
Rm <- solve(chol(A))
- decomp <- svd(crossprod(Rm, dmat) %*% Rm)
- d <- decomp$d
+ ## singular value decomposition without singular vectors
+ d <- try(svd(crossprod(Rm, dmat) %*% Rm, nu=0, nv=0)$d)
+ ## if unsucessfull try the same computation but compute singular vectors as well
+ if (inherits(d, "try-error"))
+ d <- svd(crossprod(Rm, dmat) %*% Rm)$d
### option
if (options("mboost_dftraceS")[[1]]){
@@ -200,9 +217,10 @@
if (cyclic & constraint != "none")
stop("constraints not implemented for cyclic B-splines")
stopifnot(is.numeric(deriv) & length(deriv) == 1)
+ ## prediction is usually set in/by newX()
list(knots = ret, degree = degree, differences = differences,
df = df, lambda = lambda, center = center, cyclic = cyclic,
- Ts_constraint = constraint, deriv = deriv)
+ Ts_constraint = constraint, deriv = deriv, prediction = FALSE)
}
### model.matrix for P-splines baselearner (including tensor product P-splines)
@@ -210,13 +228,14 @@
stopifnot(is.data.frame(mf))
mm <- lapply(which(colnames(mf) != vary), function(i) {
- X <- bsplines(mf[[i]],
- knots = args$knots[[i]]$knots,
- boundary.knots = args$knots[[i]]$boundary.knots,
- degree = args$degree,
- Ts_constraint = args$Ts_constraint,
- deriv = args$deriv)
- if (args$cyclic) {
+ if (!args$cyclic) {
+ X <- bsplines(mf[[i]],
+ knots = args$knots[[i]]$knots,
+ boundary.knots = args$knots[[i]]$boundary.knots,
+ degree = args$degree,
+ Ts_constraint = args$Ts_constraint,
+ deriv = args$deriv, extrapolation = args$prediction)
+ } else { ## if cyclic spline
X <- cbs(mf[[i]],
knots = args$knots[[i]]$knots,
boundary.knots = args$knots[[i]]$boundary.knots,
@@ -559,8 +578,14 @@
}
### cyclic B-splines
-### adapted version of mgcv:cSplineDes from S.N. Wood
+### adapted version of mgcv::cSplineDes from S.N. Wood
cbs <- function (x, knots, boundary.knots, degree = 3, deriv = 0L) {
+
+ if (any(x < boundary.knots[1], na.rm = TRUE) |
+ any(x > boundary.knots[2], na.rm = TRUE))
+ stop("some ", sQuote("x"), " values are beyond ",
+ sQuote("boundary.knots"))
+
nx <- names(x)
x <- as.vector(x)
## handling of NAs
@@ -593,14 +618,30 @@
attr(X, "degree") <- degree
attr(X,"knots") <- knots
attr(X,"boundary.knots") <- boundary.knots
- if (deriv != 0)
+ if (length(deriv) > 1 || deriv != 0)
attr(X, "deriv") <- deriv
dimnames(X) <- list(nx, 1L:ncol(X))
return(X)
}
bsplines <- function(x, knots, boundary.knots, degree,
- Ts_constraint = "none", deriv = 0L){
+ Ts_constraint = "none", deriv = 0L,
+ extrapolation = FALSE) {
+
+ ## do not allow data beyond boundary knots while fitting
+ if (!extrapolation && (any(x < boundary.knots[1], na.rm = TRUE) |
+ any(x > boundary.knots[2], na.rm = TRUE)))
+ stop("some ", sQuote("x"), " values are beyond ",
+ sQuote("boundary.knots"))
+
+ ## allow extrapolation when predicting
+ if (extrapolation <- extrapolation &&
+ (any(x < boundary.knots[1], na.rm = TRUE) |
+ any(x > boundary.knots[2], na.rm = TRUE))) {
+ warning("Some ", sQuote("x"), " values are beyond ",
+ sQuote("boundary.knots"), "; Linear extrapolation used.")
+ }
+
nx <- names(x)
x <- as.vector(x)
## handling of NAs
@@ -618,6 +659,27 @@
## construct design matrix
X <- splineDesign(k, x, degree + 1, derivs = rep(deriv, length(x)),
outer.ok = TRUE)
+
+ ## code along the lines of mgcv::Predict.matrix.pspline.smooth
+ if (extrapolation) {
+ ## Build matrix to map coeficients to value (deriv = 0) and
+ ## slope (deriv = 1) at end points.
+ if (deriv != 0L) {
+ warning("deriv != 0L; Linear extrapolation overwritten")
+ } else {
+ deriv <- c(0, 1, 0, 1)
+ }
+ D <- splineDesign(knots = k, x = rep(boundary.knots, each = 2),
+ ord = degree + 1, deriv)
+ ## Add rows for linear extrapolation
+ idx <- x < boundary.knots[1]
+ if (any(idx, na.rm = TRUE))
+ X[idx,] <- cbind(1, x[idx] - boundary.knots[1]) %*% D[1:2, ]
+ idx <- x > boundary.knots[2]
+ if (any(idx, na.rm = TRUE))
+ X[idx,] <- cbind(1, x[idx] - boundary.knots[2]) %*% D[3:4, ]
+ }
+
## handling of NAs
if (nas) {
tmp <- matrix(NA, length(nax), ncol(X))
@@ -638,7 +700,7 @@
attr(X, "Ts_constraint") <- Ts_constraint
if (Ts_constraint != "none")
attr(X, "D") <- D
- if (deriv != 0)
+ if (length(deriv) > 1 || deriv != 0)
attr(X, "deriv") <- deriv
dimnames(X) <- list(nx, 1L:ncol(X))
return(X)
@@ -651,25 +713,12 @@
index <- blg$get_index()
vary <- blg$get_vary()
- newX <- function(newdata = NULL) {
+ newX <- function(newdata = NULL, prediction = FALSE) {
if (!is.null(newdata)) {
- 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)
+ mf <- check_newdata(newdata, blg, mf)
}
+ ## this argument is currently only used in X_bbs --> bsplines
+ args$prediction <- prediction
return(Xfun(mf, vary, args))
}
X <- newX()
@@ -759,8 +808,7 @@
newdata <- newdata[index[[1]], , drop = FALSE]
index <- index[[2]]
}
-
- X <- newX(newdata)$X
+ X <- newX(newdata, prediction = TRUE)$X
}
aggregate <- match.arg(aggregate)
pr <- switch(aggregate, "sum" =
Modified: pkg/mboostPatch/R/bmono.R
===================================================================
--- pkg/mboostPatch/R/bmono.R 2015-08-14 13:29:22 UTC (rev 861)
+++ pkg/mboostPatch/R/bmono.R 2015-08-18 16:13:34 UTC (rev 862)
@@ -134,8 +134,7 @@
}
}
args$cons.arg <- cons.arg
- ret$dpp <- bl_mono(ret, Xfun = X_bbs,
- args = args)
+ ret$dpp <- bl_mono(ret, Xfun = X_bbs, args = args)
} else {
args <- hyper_ols(df = df, lambda = lambda,
intercept = intercept,
@@ -147,8 +146,7 @@
## <FIXME> Was machen wir bei kateg. Effekten? Da muesste das doch auch gehen!
args$boundary.constraints <- boundary.constraints
args$cons.arg$n <- cons.arg$n
- ret$dpp <- bl_mono(ret, Xfun = X_ols,
- args = args)
+ ret$dpp <- bl_mono(ret, Xfun = X_ols, args = args)
}
return(ret)
}
@@ -158,25 +156,12 @@
index <- blg$get_index()
vary <- blg$get_vary()
- newX <- function(newdata = NULL) {
+ newX <- function(newdata = NULL, prediction = FALSE) {
if (!is.null(newdata)) {
- 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)
+ mf <- check_newdata(newdata, blg, mf)
}
+ ## this argument is currently only used in X_bbs --> bsplines
+ args$prediction <- prediction
return(Xfun(mf, vary, args))
}
X <- newX()
@@ -358,7 +343,7 @@
newdata <- newdata[index[[1]], , drop = FALSE]
index <- index[[2]]
}
- X <- newX(newdata)$X
+ X <- newX(newdata, prediction = TRUE)$X
}
aggregate <- match.arg(aggregate)
pr <- switch(aggregate, "sum" =
Modified: pkg/mboostPatch/R/bmrf.R
===================================================================
--- pkg/mboostPatch/R/bmrf.R 2015-08-14 13:29:22 UTC (rev 861)
+++ pkg/mboostPatch/R/bmrf.R 2015-08-18 16:13:34 UTC (rev 862)
@@ -69,7 +69,7 @@
K <- Matrix(unclass(K))
nm <- colnames(mf)[colnames(mf) != vary]
list(K = K, bnd = bnd, pen = TRUE, df = df, lambda = lambda,
- center = center)
+ center = center)
}
X_bmrf <- function (mf, vary, args) {
Modified: pkg/mboostPatch/R/bolscw.R
===================================================================
--- pkg/mboostPatch/R/bolscw.R 2015-08-14 13:29:22 UTC (rev 861)
+++ pkg/mboostPatch/R/bolscw.R 2015-08-18 16:13:34 UTC (rev 862)
@@ -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/crossvalidation.R
===================================================================
--- pkg/mboostPatch/R/crossvalidation.R 2015-08-14 13:29:22 UTC (rev 861)
+++ pkg/mboostPatch/R/crossvalidation.R 2015-08-18 16:13:34 UTC (rev 862)
@@ -9,7 +9,8 @@
cvrisk.mboost <- function (object, folds = cv(model.weights(object)),
grid = 1:mstop(object), papply = mclapply,
- fun = NULL, corrected = TRUE, ...) {
+ fun = NULL, corrected = TRUE, mc.preschedule = FALSE,
+ ...) {
weights <- model.weights(object)
if (any(weights == 0))
@@ -71,12 +72,27 @@
## use case weights as out-of-bag weights (but set inbag to 0)
OOBweights <- matrix(rep(weights, ncol(folds)), ncol = ncol(folds))
OOBweights[folds > 0] <- 0
- oobrisk <- papply(1:ncol(folds),
- function(i) dummyfct(weights = folds[, i],
- oobweights = OOBweights[, i]), ...)
- ## get errors if mclapply is used
- if (any(idx <- sapply(oobrisk, is.character)))
- stop(sapply(oobrisk[idx], function(x) x))
+ if (all.equal(papply, mclapply) == TRUE) {
+ oobrisk <- papply(1:ncol(folds),
+ function(i) dummyfct(weights = folds[, i],
+ oobweights = OOBweights[, i]),
+ mc.preschedule = mc.preschedule,
+ ...)
+ } else {
+ oobrisk <- papply(1:ncol(folds),
+ function(i) try(dummyfct(weights = folds[, i],
+ oobweights = OOBweights[, i])),
+ ...)
+ }
+ ## if any errors occured remove results and issue a warning
+ if (any(idx <- sapply(oobrisk, is.character))) {
+ warning(sum(idx), " fold(s) encountered an error. ",
+ "Results are based on ", ncol(folds) - sum(idx),
+ " folds only.\n",
+ "Original error message(s):\n",
+ sapply(oobrisk[idx], function(x) x))
+ oobrisk[idx] <- NULL
+ }
if (!is.null(fun))
return(oobrisk)
oobrisk <- t(as.data.frame(oobrisk))
Modified: pkg/mboostPatch/R/helpers.R
===================================================================
--- pkg/mboostPatch/R/helpers.R 2015-08-14 13:29:22 UTC (rev 861)
+++ pkg/mboostPatch/R/helpers.R 2015-08-18 16:13:34 UTC (rev 862)
@@ -48,7 +48,8 @@
### rows without missings in Matrices, matrices and data.frames
Complete.cases <- function(x) {
- if (isMATRIX(x)) return(rowSums(is.na(x)) == 0)
+ if (isMATRIX(x))
+ return(rowSums(is.na(x)) == 0)
complete.cases(x)
}
@@ -234,3 +235,24 @@
bvec = rep(0, nrow(D)))$solution
cf
}
+
+check_newdata <- function(newdata, blg, mf, to.data.frame = TRUE) {
+ 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)))
+ warning("Some variables in ", sQuote("newdata"),
+ " do not have the same class as in the original data set",
+ call. = FALSE)
+ ## subset data
+ mf <- newdata[nm]
+ if (is.list(mf) && to.data.frame)
+ mf <- as.data.frame(mf)
+ return(mf)
+}
Modified: pkg/mboostPatch/R/plot.R
===================================================================
--- pkg/mboostPatch/R/plot.R 2015-08-14 13:29:22 UTC (rev 861)
+++ pkg/mboostPatch/R/plot.R 2015-08-18 16:13:34 UTC (rev 862)
@@ -67,7 +67,12 @@
if (is.factor(data[[1]])) {
xVals <- unique(sort(data[[1]]))
xValsN <- as.numeric(xVals)
- yVals <- unique(pr[order(data[[1]], na.last = NA)])
+ ## make sure that we get the same number of values as in
+ ## x; this is only a problem if pr is equal for
+ ## different x values.
+ yVals <- unique(cbind(pr[order(data[[1]], na.last = NA)],
+ sort(data[[1]])))[, 1]
+
if (length(pr) == 1 && pr == 0) {
yVals <- rep(0, length(xVals))
}
Modified: pkg/mboostPatch/inst/NEWS.Rd
===================================================================
--- pkg/mboostPatch/inst/NEWS.Rd 2015-08-14 13:29:22 UTC (rev 861)
+++ pkg/mboostPatch/inst/NEWS.Rd 2015-08-18 16:13:34 UTC (rev 862)
@@ -1,12 +1,30 @@
\name{NEWS}
\title{News for Package 'mboost'}
-\section{Changes in mboost version 2.4-3 (2015-08-12)}{
+\section{Changes in mboost version 2.5-0 (2015-08-13)}{
\subsection{User-visible changes}{
\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/14}{#14}.
+ \item Better handling of errors in (single) folds of \code{cvrisk}:
+ results of folds without errors are used and a \code{warning} is
+ issued.
+ \item \code{bbs} and \code{bmono} no longer allow data outside of
+ the \code{boundary.knots} during model fitting.
+ \item Predictions for \code{bbs} and \code{bmono} now use linear
+ extrapolation (user request inspired by
+ \code{mgcv::Predict.matrix.pspline.smooth}).
+ \item Parallel computing via \code{mclapply}: Set
+ \code{mc.preschedule = FALSE} per default.
+ \item Added new option \code{options(mboost_check_df2lambda =
+ TRUE)}, which controls if a stability check in \code{df2lambda}
+ is performed. If set to \code{FALSE} this might speed up the
+ computation of \code{df2lambda} especially with large design
+ matrices.
+ \item Prediction now also possible with \code{newdata = list()}.
+ Resolves issue
+ \href{https://github.com/hofnerb/mboost/issues/15}{#15}.
}
}
\subsection{Miscellaneous}{
@@ -19,19 +37,28 @@
Sarah Brockhaus).
\item \file{inst/CITATION}: Added subheadings and
tutorial paper.
+
+ \item Stopped computing the singular vectors in \code{df2lambda}
+ as the singular values are sufficient and as
+ \dQuote{computing the singular vectors is the slow part for large
+ matrices} (proposed by Fabian Scheipl).
}
}
\subsection{Bug-fixes}{
\itemize{
- \item Fixed bug in \code{PropOdds()} which occured if
+ \item Fixed bug in \code{PropOdds()} which occurred if
\code{offset} was specified: nuisance parameters \code{delta}
- and \code{sigma} were not properly initialized.
+ and \code{sigma} were not properly initialized (spotted by Madlene Nussbaum).
+ \item Bug in \code{plot.mboost()} fixed which occurred if a factor
+ with equal effect estimates for different categories was plotted.
+ \item Bug in \code{df2lambda} fixed: Make sure that \code{A} is
+ symmetric if it is \code{Matrix}-object (spotted by Souhaib Ben
+ Taieb).
+ \item Bug in \code{df2lambda} fixed. Design matrices were always
+ assumed to be of full rank.
\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/Family.Rd
===================================================================
--- pkg/mboostPatch/man/Family.Rd 2015-08-14 13:29:22 UTC (rev 861)
+++ pkg/mboostPatch/man/Family.Rd 2015-08-18 16:13:34 UTC (rev 862)
@@ -285,7 +285,10 @@
name = "My Gauss Variant")
}
-\donttest{
+\donttest{############################################################
+## Do not run and check these examples automatically as
+## they take some time
+
### Proportional odds model
data(iris)
iris$Species <- factor(iris$Species, ordered = TRUE)
@@ -302,17 +305,19 @@
## make thresholds comparable to a model without intercept
nuisance(mod.PropOdds) - coef(mod.PropOdds)["(Intercept)"] -
attr(coef(mod.PropOdds), "offset")
+
+## End(Not run and test)
}
### Multinomial logit model via a linear array model
-## One needs to convert the data to a list
+## One needs to convert the data to a list
myiris <- as.list(iris)
-## ... and define a dummy vector with one factor level less
+## ... and define a dummy vector with one factor level less
## than the outcome, which is used as reference category.
myiris$class <- factor(levels(iris$Species)[-nlevels(iris$Species)])
## Now fit the linear array model
mlm <- mboost(Species ~ bols(Sepal.Length, df = 2) \%O\%
- bols(class, df = 2, contrasts.arg = "contr.dummy"),
+ bols(class, df = 2, contrasts.arg = "contr.dummy"),
data = myiris,
family = Multinomial())
coef(mlm) ## one should use more boosting iterations.
@@ -326,13 +331,20 @@
## check results
pred[1, ]
pred2
-\donttest{
+
+\donttest{############################################################
+## Do not run and check these examples automatically as
+## they take some time
+
## Compare results with nnet::multinom
if (require("nnet")) {
mlmn <- multinom(Species ~ Sepal.Length, data = iris)
max(abs(fitted(mlm[1000], type = "response") -
fitted(mlmn, type = "prob")))
+
}
+
+## End(Not run and test)
}
}
Modified: pkg/mboostPatch/man/baselearners.Rd
===================================================================
--- pkg/mboostPatch/man/baselearners.Rd 2015-08-14 13:29:22 UTC (rev 861)
+++ pkg/mboostPatch/man/baselearners.Rd 2015-08-18 16:13:34 UTC (rev 862)
@@ -1,5 +1,7 @@
\name{baselearners}
\alias{baselearners}
+\alias{baselearner}
+\alias{base-learner}
\alias{bols}
\alias{bbs}
\alias{bspatial}
@@ -587,7 +589,11 @@
form2 <- y ~ bols(x1) + bols(x2) + bols(x1, by = x2, intercept = FALSE) +
bspatial(x1, x2, knots = 12, center = TRUE, df = 1)
-\donttest{ mod1 <- gamboost(form1)
+\donttest{############################################################
+## Do not run and check these examples automatically as
+## they take some time
+
+ mod1 <- gamboost(form1)
plot(mod1)
mod2 <- gamboost(form2)
@@ -598,6 +604,8 @@
df <- expand.grid(x1 = unique(x1), x2 = unique(x2))
df$pred <- predict(mod2, newdata = df)
levelplot(pred ~ x1 * x2, data = df)
+
+## End(Not run and test)
}
## specify radial basis function base-learner for spatial effect
@@ -607,14 +615,19 @@
## (not really a good setting)
form4 <- y ~ brad(x1, x2, knots = 50, args = list(theta = 0.4))
-\donttest{ mod3 <- gamboost(form3)
-plot(mod3)
-dim(extract(mod3, what = "design", which = "brad")[[1]])
-knots <- attr(extract(mod3, what = "design", which = "brad")[[1]], "knots")
+\donttest{############################################################
+## Do not run and check these examples automatically as
+## they take some time
+ mod3 <- gamboost(form3)
+ plot(mod3)
+ dim(extract(mod3, what = "design", which = "brad")[[1]])
+ knots <- attr(extract(mod3, what = "design", which = "brad")[[1]], "knots")
-mod4 <- gamboost(form4)
-dim(extract(mod4, what = "design", which = "brad")[[1]])
-plot(mod4)
+ mod4 <- gamboost(form4)
+ dim(extract(mod4, what = "design", which = "brad")[[1]])
+ plot(mod4)
+
+## End(Not run and test)
}
### random intercept
@@ -697,7 +710,11 @@
signif(cf_center, 3)
signif(coef(lm(y ~ x, data = tmpdata)), 3)
-\donttest{ ### large data set with ties
+\donttest{############################################################
+## Do not run and check these examples automatically as
+## they take some time
+
+ ### large data set with ties
nunique <- 100
xindex <- sample(1:nunique, 1000000, replace = TRUE)
x <- runif(nunique)
@@ -723,6 +740,8 @@
all.equal(c1, c2)
all.equal(c1, c3)
+
+## End(Not run and test)
}
### cyclic P-splines
@@ -791,7 +810,11 @@
volf <- matrix(fitted(mod), nrow = nrow(volcano))
image(volf, main = "fitted")
-\donttest{ ## the old-fashioned way, a waste of space and time
+\donttest{############################################################
+## Do not run and check these examples automatically as
+## they take some time
+
+ ## the old-fashioned way, a waste of space and time
x <- expand.grid(x1, x2)
modx <- mboost(vol ~ bbs(Var2, df = 3, knots = 10) \%X\%
bbs(Var1, df = 3, knots = 10), data = x,
@@ -799,6 +822,8 @@
modx[250]
max(abs(fitted(mod) - fitted(modx)))
+
+## End(Not run and test)
}
### setting contrasts via contrasts.arg
Modified: pkg/mboostPatch/man/confint.Rd
===================================================================
--- pkg/mboostPatch/man/confint.Rd 2015-08-14 13:29:22 UTC (rev 861)
+++ pkg/mboostPatch/man/confint.Rd 2015-08-18 16:13:34 UTC (rev 862)
@@ -132,6 +132,10 @@
}
\examples{
\donttest{
+############################################################
+## Do not run these examples automatically as they take
+## some time (~ 30 seconds depending on the system)
+
### a simple linear example
set.seed(1907)
data <- data.frame(x1 = rnorm(100), x2 = rnorm(100),
Modified: pkg/mboostPatch/man/cvrisk.Rd
===================================================================
--- pkg/mboostPatch/man/cvrisk.Rd 2015-08-14 13:29:22 UTC (rev 861)
+++ pkg/mboostPatch/man/cvrisk.Rd 2015-08-18 16:13:34 UTC (rev 862)
@@ -10,7 +10,7 @@
\method{cvrisk}{mboost}(object, folds = cv(model.weights(object)),
grid = 1:mstop(object),
papply = mclapply,
- fun = NULL, corrected = TRUE, ...)
+ fun = NULL, corrected = TRUE, mc.preschedule = FALSE, ...)
cv(weights, type = c("bootstrap", "kfold", "subsampling"),
B = ifelse(type == "kfold", 10, 25), prob = 0.5, strata = NULL)
}
@@ -35,7 +35,12 @@
\item{corrected}{ if \code{TRUE}, the corrected cross-validation
scheme of Verweij and van Houwelingen (1993) is used in case of Cox
models. Otherwise, the naive standard cross-validation scheme is
- used.}
+ used.
+ }
+ \item{mc.preschedule}{
+ preschedule tasks if are parallelized using \code{\link{mclapply}}
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/mboost -r 862
More information about the Mboost-commits
mailing list