[Coxflexboost-commits] r9 - in pkg: . R inst man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Mar 12 17:49:48 CET 2009
Author: hofner
Date: 2009-03-12 17:49:48 +0100 (Thu, 12 Mar 2009)
New Revision: 9
Modified:
pkg/NAMESPACE
pkg/R/PMLE.R
pkg/R/cfboost.R
pkg/R/integr.R
pkg/R/methods.R
pkg/inst/CHANGES
pkg/man/methods.Rd
Log:
- improved plot.cfboost (for time-varying effects)
- minor changes for integration
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2009-03-02 17:24:18 UTC (rev 8)
+++ pkg/NAMESPACE 2009-03-12 16:49:48 UTC (rev 9)
@@ -1,4 +1,3 @@
-#import(mboost)
import(modeltools)
export(cfboost, boost_control, mstop, risk, freq.sel,
@@ -23,3 +22,4 @@
S3method(predict, baselearner)
+#useDynLib(CoxFlexBoost)
Modified: pkg/R/PMLE.R
===================================================================
--- pkg/R/PMLE.R 2009-03-02 17:24:18 UTC (rev 8)
+++ pkg/R/PMLE.R 2009-03-12 16:49:48 UTC (rev 9)
@@ -64,7 +64,7 @@
}
## build design matrix for currently added base-learner
- if (attr(x[[added_bl]], "timedep")){
+ if (added_td <- attr(x[[added_bl]], "timedep")){
xd <- unlist(grid)
xname <- get("xname", environment(attr(x[[added_bl]], "predict")))
zd <- get("z", environment(attr(x[[added_bl]], "predict")))
@@ -86,9 +86,12 @@
exp_pred_tconst <- exp(predictions_tconst * nu)
exp_pred_td <- exp(predictions_td * nu)
+ old_coefs <- attr(x[[added_bl]], "coefs")
+
+
logLH_pen <- function(coefs){
log_lik <- sum(delta * (fit + x[[added_bl]] %*% coefs)
- - integr(x[[added_bl]], coefs, desMat,
+ - integr(old_coefs, added_td, coefs, desMat,
predictions = list(offset = exp_offset, tconst = exp_pred_tconst, td = exp_pred_td),
controls = list(grid = grid, trapezoid_width = trapezoid_width, upper = time, nu = nu)))
if (is.null(pen)) pen <- 0 else pen <- 0.5 * (coefs %*% pen %*% coefs)
Modified: pkg/R/cfboost.R
===================================================================
--- pkg/R/cfboost.R 2009-03-02 17:24:18 UTC (rev 8)
+++ pkg/R/cfboost.R 2009-03-12 16:49:48 UTC (rev 9)
@@ -72,11 +72,15 @@
df_est <- matrix(NA, nrow = mstop, ncol = length(x)) # matrix of estimated degrees of freedom
## compute df2lambda which depends on the offset and on y
+ if (trace)
+ cat("compute df2lambda .")
for (i in 1:length(x)){
if (!is.null( attr(x[[i]], "df"))){
attr(x[[i]], "df2lambda")(y, offset)
+ if (trace) cat(".")
}
}
+ if (trace) cat("\n")
##################################
#### start boosting iteration ####
@@ -84,7 +88,7 @@
repeat{
for (m in mstart:mstop) {
if (trace)
- cat("Step ", m, "\n")
+ cat("Step ", m, "; Progress .")
## fit MLE component-wise
for (i in 1:length(x)) {
@@ -98,7 +102,9 @@
maxll[i] <- dummy$maxll
logLH[[i]] <- dummy$logLH
if (!is.null(dummy$df)) df_est[m,i] <- dummy$df
+ if (trace) cat(".")
}
+ if (trace) cat("\n")
if (all(is.na(maxll)))
stop("could not fit base learner in boosting iteration ", m)
Modified: pkg/R/integr.R
===================================================================
--- pkg/R/integr.R 2009-03-02 17:24:18 UTC (rev 8)
+++ pkg/R/integr.R 2009-03-12 16:49:48 UTC (rev 9)
@@ -2,7 +2,7 @@
## Integration Using the Trapezoidal Rule ##
############################################
-integr <- function(x, coefs, desMat, predictions = list(), controls = list(), ...){
+integr <- function(old_coefs, added_td, coefs, desMat, predictions = list(), controls = list(), ...){
###
# x currently added base-learner
# coefs the current coefficients
@@ -20,9 +20,9 @@
if (length(predictions$offset) != 1) stop(sQuote("offset"), " must be a single constant")
- coefs <- coefs + controls$nu * attr(x, "coefs")
+ coefs <- coefs + controls$nu * old_coefs
foo <- desMat %*% coefs
- if(attr(x, "timedep")){
+ if(added_td){
foo <- matrix(foo, nrow = length(controls$grid), ncol = length(controls$grid[[1]]), byrow = TRUE)
predictions$td <- predictions$td * exp(foo)
} else {
Modified: pkg/R/methods.R
===================================================================
--- pkg/R/methods.R 2009-03-02 17:24:18 UTC (rev 8)
+++ pkg/R/methods.R 2009-03-12 16:49:48 UTC (rev 9)
@@ -58,8 +58,10 @@
}
## methods: plot for cfboost objects
-plot.cfboost <- function(x, which = NULL, ask = TRUE && dev.interactive(),
- type = "b", ylab = expression(f[partial]), add_rug = TRUE, ...){
+plot.cfboost <- function(x, which = NULL, ask = TRUE && dev.interactive(), type = "b",
+ ylab = expression(f[partial]), add_rug = TRUE,
+ color.palette = c("heat.colors", "terrain.colors", "topo.colors", "cm.colors", "rainbow", "none"), ...){
+ color.palette <- match.arg(color.palette)
tmp <- x$data$input
class(tmp) <- "list"
@@ -76,7 +78,26 @@
if (!is.null(zname) & zname != "NULL")
ixname <- paste(ixname, " (as interaction with ", zname, ")", sep="")
ixorder <- order(ix)
- plot(ix[ixorder], attr(tmp[[i]], "predict")(x$coefs[[i]])[ixorder], type = type, ylab = ylab, xlab = ixname)
+ if (!attr(tmp[[i]], "timedep")){
+ plot(ix[ixorder], attr(tmp[[i]], "predict")(x$coefs[[i]])[ixorder], type = type, ylab = ylab, xlab = ixname)
+ } else {
+ iz <- get("z", environment(attr(tmp[[i]],"predict")))
+ if (!is.null(iz) && length(unique(iz))==2){ ## for time-varying effects of binary covariates z
+ sel <- (iz == sort(unique(iz))[2])[ixorder]
+ yi <- attr(tmp[[i]], "predict")(x$coefs[[i]])[ixorder]
+ plot(ix[ixorder][sel], yi[sel], type = type, ylab = ylab, xlab = ixname)
+ lines(ix[ixorder][!sel], yi[!sel], type = type)
+ } else {
+ if(!is.null(iz) && color.palette != "none"){ ## for time-varying effects of other covariates z (with colors for changing z)
+ foo <- eval(parse(text=color.palette))
+ colors <- factor(iz)
+ levels(colors) <- foo(length(levels(colors)))
+ plot(ix[ixorder], attr(tmp[[i]], "predict")(x$coefs[[i]])[ixorder], type = "p", col=as.character(colors), ylab = ylab, xlab = ixname)
+ } else {
+ plot(ix[ixorder], attr(tmp[[i]], "predict")(x$coefs[[i]])[ixorder], type = "p", ylab = ylab, xlab = ixname)
+ }
+ }
+ }
abline(h = 0, lty = 3)
if (add_rug) rug(ix)
}
@@ -157,3 +178,5 @@
}
invisible(x)
}
+
+
Modified: pkg/inst/CHANGES
===================================================================
--- pkg/inst/CHANGES 2009-03-02 17:24:18 UTC (rev 8)
+++ pkg/inst/CHANGES 2009-03-12 16:49:48 UTC (rev 9)
@@ -7,6 +7,8 @@
o changed dependencies: droped mboost (as it depends on many other packages)
and added modeltools instead
+ o improved plot.cfboost (for time-varying effects)
+
o TODO: change integration
Modified: pkg/man/methods.Rd
===================================================================
--- pkg/man/methods.Rd 2009-03-02 17:24:18 UTC (rev 8)
+++ pkg/man/methods.Rd 2009-03-12 16:49:48 UTC (rev 9)
@@ -19,7 +19,9 @@
\method{print}{cfboost}(x, ...)
\method{summary}{cfboost}(object, ...)
\method{plot}{cfboost}(x, which = NULL, ask = TRUE && dev.interactive(),
- type = "b", ylab = expression(f[partial]), add_rug = TRUE, ...)
+ type = "b", ylab = expression(f[partial]), add_rug = TRUE,
+ color.palette = c("heat.colors", "terrain.colors", "topo.colors",
+ "cm.colors", "rainbow", "none"), ...)
\method{coef}{cfboost}(object, ...)
\method{[}{cfboost}(object, i, ...)
}
@@ -35,6 +37,12 @@
details.}
\item{ylab}{ A title for the y axis. }
\item{add_rug}{ logic. Determines if \code{\link{rug}}s are added. }
+ \item{color.palette}{ character. Determines how time-varying effects
+ of non-binary covariates should be ploted. A color palette of
+ "heat.colors", "terrain.colors", "topo.colors", "cm.colors",
+ "rainbow" is specified (as character). See \code{\link{rainbow}}
+ for details. If "none" is specified, all observations are
+ printed in black. }
\item{i}{ integer. Index specifying the model to extract. See example
for more details.}
\item{\dots}{ additional arguments (not used a.t.m.) }
More information about the Coxflexboost-commits
mailing list