version 0.2-3

CHANGES

@@ -1,27 +1,42 @@
+CHANGES IN `modeltools' VERSION 0.2-3
 
-                CHANGES IN `modeltools' VERSION 0.2-2
+  o checkData does no longer insist that columns of a new data frame
+    are in the same order as in the original data frame.
 
+  o fxied a bug in the show() method for ModelEnv objects
 
-    o    remove special code for `Surv' objects in ParseFormula
+  o new ModelEnv creator function ModelEnvMatrix
 
+  o `linearModel@fit' now returns an object of class `linearModel'
+
+  o `glinearModel' object added
+
+  o S3 methods for (g)linearModel objects added (fitted, model.matrix, ...)
+
 
-                CHANGES IN `modeltools' VERSION 0.2-0
+CHANGES IN `modeltools' VERSION 0.2-2
 
 
-    o    `Predict' checks for `StatModel' objects being available
+  o remove special code for `Surv' objects in ParseFormula
 
-    o    `linearModel@fit' now returns an object of class `statmodel_lm'
-         which inherits from `lm' and has its own `predict' method (in S3)
 
-    o    prepare for CRAN submission
+CHANGES IN `modeltools' VERSION 0.2-0
 
 
-                CHANGES IN `modeltools' VERSION 0.1-2
+  o `Predict' checks for `StatModel' objects being available
 
+  o `linearModel@fit' now returns an object of class `statmodel_lm'
+    which inherits from `lm' and has its own `predict' method (in S3)
 
-    o    `set' and `get' functions have an additional `envir' argument. This is
-         now used by `clone', for example.
+  o prepare for CRAN submission
 
-    o    lmfit now returns a `lm' object with element `predict_response' for
-         computing predictions.
+
+CHANGES IN `modeltools' VERSION 0.1-2
+
+
+  o `set' and `get' functions have an additional `envir' argument. This is
+    now used by `clone', for example.
+
+  o lmfit now returns a `lm' object with element `predict_response' for
+    computing predictions.
 

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: modeltools
 Title: Tools and Classes for Statistical Models
-Date: $Date: 2005-06-15 10:08:19 +0200 (Wed, 15 Jun 2005) $
-Version: 0.2-2
-Author: Torsten Hothorn and Friedrich Leisch
+Date: $Date: 2006-02-15 22:52:45 +0100 (Wed, 15 Feb 2006) $
+Version: 0.2-3
+Author: Torsten Hothorn, Friedrich Leisch, Achim Zeileis
 Maintainer: Torsten Hothorn <Torsten.Hothorn@R-project.org>
 Description: A collection of tools to deal with statistical models. 
   The functionality is experimental and the user interface is likely to
@@ -13,4 +13,4 @@ Description: A collection of tools to deal with statistical models.
 Depends: R (>= 2.0.1)
 SaveImage: yes
 License: GPL
-Packaged: Tue Nov 29 11:26:23 2005; hothorn
+Packaged: Wed Feb 15 22:52:58 2006; zeileis

NAMESPACE

@@ -1,12 +1,20 @@
 
 import(methods)
 
-export(ModelEnvFormula, linearModel, Predict)
+export(ModelEnvFormula, ModelEnvMatrix, linearModel, glinearModel, Predict)
 
 exportClasses("ModelEnv", "FormulaParts", "ModelEnvFormula", "StatModel",
               "StatModelCapabilities")
 
 exportMethods("subset", "show", "dimension", "clone", "has", "initialize",
               "fit", "dpp", "na.omit", "na.fail", "na.pass", "subset")
 
-S3method(predict, statmodel_lm)
+S3method(fitted, glinearModel)
+S3method(fitted, linearModel)
+S3method(model.matrix, glinearModel)
+S3method(model.matrix, linearModel)
+S3method(predict, glinearModel)
+S3method(predict, linearModel)
+S3method(print, glinearModel)
+S3method(print, linearModel)
+S3method(weights, linearModel)

R/Data.R

@@ -5,7 +5,8 @@
 ModelEnvFormula <- function(formula, data = list(), subset = NULL, 
                             na.action = NULL, frame = NULL,
                             other = list(), designMatrix = TRUE,
-                            responseMatrix = TRUE, ...) {
+                            responseMatrix = TRUE, ...)
+{
 
     mf <- match.call(expand.dots = FALSE)
     m <- match(c("formula", "data", "subset", "na.action"),
@@ -92,11 +93,14 @@ ModelEnvFormula <- function(formula, data = list(), subset = NULL,
 checkData <- function(old, new) {
 
     if (!is.null(old)){
-
-        if (!identical(lapply(old, class), lapply(new, class)))
+
+        if(!all(names(old) %in% names(new)))
+            stop("New data must contain the same columns as the original data")
+
+        if (!identical(lapply(old, class), lapply(new[names(old)], class)))
             stop("Classes of new data do not match original data")
 
-        if (!identical(lapply(old, levels), lapply(new, levels)))
+        if (!identical(lapply(old, levels), lapply(new[names(old)], levels)))
             stop("Levels in factors of new data do not match original data")
     }
 }
@@ -147,3 +151,88 @@ ParseFormula <- function(formula, data = list()) {
 
     return(RET)
 }
+
+
+###**********************************************************
+
+## A simple model environment where designMatrix and responseMatrix
+## are directly specified. Usefull for models without a formula
+## interface. This is much more limited than ModelEnvFormula, but can
+## be faster because no formula parsing is necessary. The subset
+## argument needs to be a indexing vector into the design and response
+## matrix, respectively. Funny things may happen if the matrices have
+## no column names and the @[gs]et slots are used in combination with
+## new data <FIXME>is proper handling of that case possible?</FIXME>
+
+ModelEnvMatrix <- function(designMatrix=NULL, responseMatrix=NULL,
+                           subset = NULL, na.action = NULL,
+                           ...)
+{    
+    MEM <- new("ModelEnv")
+
+    N <- max(nrow(designMatrix), nrow(responseMatrix))
+
+    if(is.null(subset) && N>0) subset <- 1:N
+
+    if(!is.null(designMatrix))
+        assign("designMatrix",
+               as.matrix(designMatrix)[subset,,drop=FALSE],
+               envir = MEM@env)
+
+    if(!is.null(designMatrix))
+        assign("responseMatrix",
+               as.matrix(responseMatrix)[subset,,drop=FALSE],
+               envir = MEM@env)
+
+    MEM@get <- function(which, data=NULL, frame=NULL, envir = MEM@env)
+    {
+        if(is.null(data))
+            RET <- get(which, envir = envir, inherits=FALSE)
+        else
+        {    
+            if(is.null(colnames(data)))
+                colNames(data) <- createColnames(data)
+
+            oldNames <- colnames(get(which, envir = envir,
+                                     inherits=FALSE))
+            RET <- data[,oldNames,drop=FALSE]
+        }
+        return(RET)
+    }
+
+    MEM@set <- function(which = NULL, data = NULL, frame=NULL,
+                        envir = MEM@env)
+    {
+        if(is.null(which))
+            which <- c("designMatrix", "responseMatrix")
+
+        if(is.null(data))
+            stop("No data specified")
+
+        if (any(duplicated(which)))
+            stop("Some model terms used more than once")
+
+        if(is.null(colnames(data)))
+            colNames(data) <- createColnames(data)
+
+        for (name in which){
+
+            oldNames <- colnames(get(name, envir = envir,
+                                     inherits=FALSE))
+
+            assign(name, as.matrix(data[,oldNames,drop=FALSE]),
+                   envir = envir)            
+        }
+    }
+
+    ## handle NA's
+    if (!is.null(na.action))
+        MEM <- na.action(MEM)
+    MEM
+}
+
+## Make sure that every matrix has column names
+createColnames <- function(data)
+{
+    paste("V",1:ncol(data),sep=".")
+}

R/Methods.R

@@ -46,7 +46,7 @@ setMethod("show", signature = "ModelEnv",
     }
     else if (has(object, "designMatrix")) {
         cat("  design matrix column(s): ",
-            colnames(object@get("input")), "\n")
+            colnames(object@get("designMatrix")), "\n")
         n <- nrow(object@get("designMatrix"))
     }
 
@@ -59,6 +59,7 @@ setMethod("show", signature = "ModelEnv",
 })
 
 
+
 setGeneric("has", function(object, which) standardGeneric("has"))
 
 setMethod("has", signature(object = "ModelEnv", which = "character"),

R/glinearModel.R

@@ -0,0 +1,61 @@
+glinearModel <- new("StatModel",
+    capabilities = new("StatModelCapabilities"),
+    name = "generalized linear regression model",
+    dpp = ModelEnvFormula,
+    fit = function(object, weights = NULL, ...){
+
+        if (is.null(weights)) {
+            z <- glm.fit(x = object@get("designMatrix"),
+                         y = object@get("response")[,1],
+                         intercept = all(object@get("designMatrix")[,1] == 1),
+                         ...)
+        } else {
+            z <- glm.fit(x = object@get("designMatrix"),
+                         y = object@get("response")[,1], 
+                         weights = weights, 
+                         intercept = all(object@get("designMatrix")[,1] == 1),
+                         ...)
+        }
+        class(z) <- c("glinearModel", "glm", "lm")
+        z$offset <- 0
+        z$contrasts <- attr(object@get("designMatrix"), "contrasts")
+
+        ## terms should be there, but still need to
+	## be worked around in predictions
+        z$terms <- attr(object@get("input"), "terms")
+        z$predict_response <- function(newdata = NULL) {
+            if (!is.null(newdata)) {
+                penv <- new.env()
+                object@set("input", data = newdata, env = penv)
+                dm <- get("designMatrix", envir = penv, inherits = FALSE)
+            } else {
+                dm <- object@get("designMatrix")
+            }
+            pr <- z$family$linkinv(drop(dm %*% z$coef))
+            return(pr)
+        }
+        z$addargs <- list(...)
+	z$ModelEnv <- object
+        z
+    },
+    predict = function(object, newdata = NULL, ...) 
+        object$predict_response(newdata = newdata)
+)
+
+predict.glinearModel <- function(object, newdata = NULL, ...)
+    object$predict_response(newdata = newdata) 
+
+fitted.glinearModel <- function(object, ...)
+    object$predict_response()
+
+print.glinearModel <- function(x, digits = max(3, getOption("digits") - 3), ...)
+{
+    fam <- x$family$family
+    substr(fam, 1, 1) <- toupper(substr(fam, 1, 1))
+    cat(paste(fam, "GLM with coefficients:\n"))
+    print.default(format(coef(x), digits = digits), print.gap = 2, quote = FALSE)
+    invisible(x)
+}
+
+model.matrix.glinearModel <- function(object, ...)
+  object$ModelEnv@get("designMatrix")

R/linearModel.R

@@ -15,14 +15,14 @@ lmfit <- function(object, weights = NULL, ...){
     }
 
     ### returns a model inheriting from `mlm' or / and `lm'
-    class(z) <- c("statmodel_lm", if (is.matrix(z$fitted)) "mlm", "lm")
+    class(z) <- c("linearModel", if (is.matrix(z$fitted)) "mlm", "lm")
     z$offset <- 0
     z$contrasts <- attr(object@get("designMatrix"), "contrasts")
     z$xlevels <- attr(object@get("designMatrix"), "xlevels")
     z$terms <- attr(object@get("input"), "terms")
 
     ### predict.lm will fails since we cannot provide 
-    ### correct $Call and $terms elements.
+    ### correct $call and $terms elements.
     z$predict_response <- function(newdata = NULL) {
         if (!is.null(newdata)) {
             penv <- new.env()
@@ -35,6 +35,8 @@ lmfit <- function(object, weights = NULL, ...){
         if (ncol(pr) == 1) pr <- drop(pr)
         return(pr)
     }
+    z$addargs <- list(...)
+    z$ModelEnv <- object
     z$statmodel <- linearModel
     z
 }
@@ -52,5 +54,22 @@ linearModel <- new("StatModel",
 )
 
 ### we would like to advocate `Predict', but anyway
-predict.statmodel_lm <- function(object, newdata = NULL, ...)
+predict.linearModel <- function(object, newdata = NULL, ...)
     linearModel@predict(object, newdata = newdata)
+
+fitted.linearModel <- function(object, ...)
+    object$predict_response()
+
+weights.linearModel <- function(object, ...) {
+    if(is.null(object$weights)) rep(1, NROW(object$residuals)) else object$weights
+}
+
+print.linearModel <- function(x, digits = max(3, getOption("digits") - 3), ...)
+{
+    cat("Linear model with coefficients:\n")
+    print.default(format(coef(x), digits = digits), print.gap = 2, quote = FALSE)
+    invisible(x)
+}
+
+model.matrix.linearModel <- function(object, ...)
+  object$ModelEnv@get("designMatrix")

inst/CHANGES

@@ -1,27 +1,42 @@
+CHANGES IN `modeltools' VERSION 0.2-3
 
-                CHANGES IN `modeltools' VERSION 0.2-2
+  o checkData does no longer insist that columns of a new data frame
+    are in the same order as in the original data frame.
 
+  o fxied a bug in the show() method for ModelEnv objects
 
-    o    remove special code for `Surv' objects in ParseFormula
+  o new ModelEnv creator function ModelEnvMatrix
 
+  o `linearModel@fit' now returns an object of class `linearModel'
+
+  o `glinearModel' object added
+
+  o S3 methods for (g)linearModel objects added (fitted, model.matrix, ...)
+
 
-                CHANGES IN `modeltools' VERSION 0.2-0
+CHANGES IN `modeltools' VERSION 0.2-2
 
 
-    o    `Predict' checks for `StatModel' objects being available
+  o remove special code for `Surv' objects in ParseFormula
 
-    o    `linearModel@fit' now returns an object of class `statmodel_lm'
-         which inherits from `lm' and has its own `predict' method (in S3)
 
-    o    prepare for CRAN submission
+CHANGES IN `modeltools' VERSION 0.2-0
 
 
-                CHANGES IN `modeltools' VERSION 0.1-2
+  o `Predict' checks for `StatModel' objects being available
 
+  o `linearModel@fit' now returns an object of class `statmodel_lm'
+    which inherits from `lm' and has its own `predict' method (in S3)
 
-    o    `set' and `get' functions have an additional `envir' argument. This is
-         now used by `clone', for example.
+  o prepare for CRAN submission
 
-    o    lmfit now returns a `lm' object with element `predict_response' for
-         computing predictions.
+
+CHANGES IN `modeltools' VERSION 0.1-2
+
+
+  o `set' and `get' functions have an additional `envir' argument. This is
+    now used by `clone', for example.
+
+  o lmfit now returns a `lm' object with element `predict_response' for
+    computing predictions.