version 0.2-0

CHANGES

@@ -0,0 +1,20 @@
+
+
+                CHANGES IN `modeltools' VERSION 0.2-0
+
+    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    prepare for CRAN submission
+
+
+                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

@@ -0,0 +1,16 @@
+Package: modeltools
+Title: Tools and Classes for Statistical Models
+Date: $Date: 2005-06-15 09:55:44 +0200 (Wed, 15 Jun 2005) $
+Version: 0.2-0
+Author: Torsten Hothorn and Friedrich Leisch
+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
+  change in the future. The documentation is rather terse, but packages `coin'
+  and `party' have some working examples. However, if you find the
+  implemented ideas interesting we would be very interested in a discussion
+  of this proposal. Contributions are more than welcome!
+Depends: R (>= 2.0.1)
+SaveImage: yes
+License: GPL
+Packaged: Wed Jun 15 09:57:46 2005; hothorn

NAMESPACE

@@ -0,0 +1,12 @@
+
+import(methods)
+
+export(ModelEnvFormula, linearModel, 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)

R/Classes.R

@@ -0,0 +1,40 @@
+
+### a class for model environments
+
+setClass("ModelEnv",
+    representation(
+        env = "environment",
+        get = "function",
+        set = "function")
+)
+
+### a class for formulae
+
+setClass("FormulaParts",
+    representation(
+        formula = "list"
+    )
+)
+
+### model environments given by formulae       
+
+setClass("ModelEnvFormula", contains = c("ModelEnv", "FormulaParts"))
+
+### A prototype for a model class in R
+
+setClass("StatModelCapabilities",
+    representation(
+        weights = "logical",
+        subset  = "logical"),
+    prototype(weights = TRUE, subset = TRUE)
+)
+
+setClass("StatModel",
+    representation(
+        name         = "character",
+        dpp          = "function",
+        fit          = "function",
+        predict      = "function",
+        capabilities = "StatModelCapabilities")
+)
+

R/Data.R

@@ -0,0 +1,159 @@
+
+### Parse and evaluate a formula, return the data as object of class 
+### `ModelEnv'
+
+ModelEnvFormula <- function(formula, data = list(), subset = NULL, 
+                            na.action = NULL, frame = NULL,
+                            other = list(), designMatrix = TRUE,
+                            responseMatrix = TRUE, ...) {
+
+    mf <- match.call(expand.dots = FALSE)
+    m <- match(c("formula", "data", "subset", "na.action"),
+               names(mf), 0)
+    mf <- mf[c(1, m)]
+    mf[[1]] <- as.name("model.frame")
+    if (is.null(subset)) mf$subset <- NULL
+
+    ### NA-handling will for the ModelFrame objects later on...
+    mf$na.action <- stats::na.pass
+
+    MEF <- new("ModelEnvFormula")
+    MEF@formula <- c(ParseFormula(formula, data=data)@formula, other)
+
+    if (is.null(frame)) frame <- parent.frame()
+
+    MEF@get <- function(which, data=NULL, frame=parent.frame(), envir = MEF@env)
+    {
+        if(is.null(data))
+            RET <- get(which, envir = envir, inherits=FALSE)
+        else{
+            oldData <- get(which, envir = envir, inherits=FALSE)
+            mf$data <- data
+            mf$formula <- MEF@formula[[which]]
+            RET <- eval(mf, frame)
+            checkData(oldData, RET)
+        }
+        return(RET)
+    }
+
+    MEF@set <- function(which = NULL, data = NULL, frame = parent.frame(),
+                        envir = MEF@env)
+    {
+        if (is.null(which)) which <- names(MEF@formula)
+        if (any(duplicated(which)))
+            stop("Some model terms used more than once")
+
+        for (name in which){
+
+            if (length(MEF@formula[[name]]) != 2)
+                stop("Invalid formula for ", sQuote(name))
+
+            mf$data <- data
+            mf$formula <- MEF@formula[[name]]
+
+            ### <FIXME> if subset was specied, we try to evaluate it
+            ###         everytime `set' is called, even for new data
+            ### </FIXME>
+            MF <- eval(mf, frame)
+            if (exists(name, envir = envir, inherits = FALSE))
+                checkData(get(name, envir = envir, inherits = FALSE), MF)
+            assign(name, MF, envir = envir)
+            mt <- attr(MF, "terms")
+
+            ## <FIXME>
+            ## maybe we don't want to save input and response
+            ## in the cases below?
+            ## </FIXME>
+            if (name == "input" && designMatrix) {
+                assign("designMatrix",
+                       model.matrix(mt, data = MF, ...),
+                       envir = envir)
+            }
+
+            if (name == "response" && responseMatrix) {
+                attr(mt, "intercept") <- 0
+                assign("responseMatrix",
+                       model.matrix(mt, data=MF, ...),
+                       envir = envir)
+            }
+        }
+    }
+
+    MEF@set(which = NULL, data = data, frame = frame)
+
+    ### handle NA's
+    if (!is.null(na.action))
+        MEF <- na.action(MEF)
+    MEF
+}
+
+### compare basic properties of two data.frames
+
+checkData <- function(old, new) {
+
+    if (!is.null(old)){
+
+        if (!identical(lapply(old, class), lapply(new, class)))
+            stop("Classes of new data do not match original data")
+
+        if (!identical(lapply(old, levels), lapply(new, levels)))
+            stop("Levels in factors of new data do not match original data")
+    }
+}
+
+### parse a formula and return the different pieces as `FormulaParts'
+### object
+
+ParseFormula <- function(formula, data = list()) {
+
+    formula <- terms(formula, data = data)
+    attributes(formula) <- NULL
+
+    if (length(formula) == 3) {
+        fresponse <- formula[c(1,2)]
+        frhs <- formula[c(1,3)]
+        if (frhs[[2]] == "1")
+            frhs <- NULL
+    }
+
+    if (length(formula) == 2) {
+        fresponse <- NULL   
+        frhs <- formula
+    }
+
+    finput <- frhs
+    fblocks <- frhs
+
+    ### <FIXME>
+    ### will fail for `y ~ . | blocks' constructs
+    ### </FIXME>
+
+    if (!is.null(frhs) && length(frhs[[2]]) > 1) {
+        if (deparse(frhs[[2]][[1]]) == "|") {
+            finput[[2]] <- frhs[[2]][[2]]
+            fblocks[[2]] <- frhs[[2]][[3]]
+        } else {
+            fblocks <- NULL
+        }
+    } else {
+        fblocks <- NULL
+    }
+
+    fcensored <- NULL
+
+    if (!is.null(fresponse) && length(fresponse[[2]]) == 3) {
+        if (fresponse[[2]][[1]] == "Surv") {
+            fcensored <- formula(paste("~", fresponse[[2]][[3]]))
+            fresponse <- formula(paste("~", fresponse[[2]][[2]])) 
+        }
+    }
+
+    RET = new("FormulaParts")
+
+    RET@formula$response <- fresponse
+    RET@formula$input <- finput
+    RET@formula$censored <- fcensored
+    RET@formula$blocks <- fblocks
+
+    return(RET)
+}