Skip to content

Commit

Permalink
version 0.2-10
Browse files Browse the repository at this point in the history
  • Loading branch information
thothorn authored and gaborcsardi committed Jan 11, 2007
1 parent 17eb10f commit 09ecbcf
Show file tree
Hide file tree
Showing 10 changed files with 190 additions and 29 deletions.
10 changes: 8 additions & 2 deletions CHANGES
Original file line number Diff line number Diff line change
@@ -1,5 +1,11 @@
CHANGES IN `modeltools' VERSION 0.2-10

CHANGES IN `modeltools' VERSION 0.2-8
o Added several generic functions: ICL, KLdiv, cluster, getModel, parameters,
posterior, prior, refit, info, infoCheck

o fix problems with evaluating subset arguments

CHANGES IN `modeltools' VERSION 0.2-9

o the following code didn't work

Expand All @@ -9,7 +15,7 @@ CHANGES IN `modeltools' VERSION 0.2-8
a <- 1:10
b <- 1:10
stopifnot(identical(foo(a, b, subset = 1:5)@get("response")[[1]],1:5))
### was: couldn't find `y' when rame' wasn't specified
### was: couldn't find `y' when `frame' wasn't specified

x <- 1
y <- 2
Expand Down
11 changes: 6 additions & 5 deletions DESCRIPTION
Original file line number Diff line number Diff line change
@@ -1,16 +1,17 @@
Package: modeltools
Title: Tools and Classes for Statistical Models
Date: $Date: 2006-11-03 11:17:22 +0100 (Fri, 03 Nov 2006) $
Version: 0.2-9
Author: Torsten Hothorn, Friedrich Leisch, Achim Zeileis
Date: $Date: 2007-01-11 18:42:45 +0100 (Thu, 11 Jan 2007) $
Version: 0.2-10
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
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), methods, stats
Depends: stats, stats4
Imports: methods
SaveImage: yes
License: GPL
Packaged: Fri Nov 3 13:01:23 2006; hothorn
Packaged: Thu Jan 11 18:53:50 2007; leisch
8 changes: 5 additions & 3 deletions NAMESPACE
Original file line number Diff line number Diff line change
@@ -1,14 +1,16 @@

import(methods)
import(stats)

export(ModelEnvFormula, ModelEnvMatrix, linearModel, glinearModel, survReg, Predict)
export(ModelEnvFormula, ModelEnvMatrix, linearModel, glinearModel,
survReg, Predict, ICL, KLdiv, cluster, getModel, parameters,
posterior, prior, refit, info, infoCheck)

exportClasses("ModelEnv", "FormulaParts", "ModelEnvFormula", "StatModel",
"StatModelCapabilities")

exportMethods("subset", "show", "dimension", "clone", "has", "initialize",
"fit", "dpp", "na.omit", "na.fail", "na.pass", "subset",
"MEapply")
"MEapply", "info")

S3method(fitted, linearModel)
S3method(model.matrix, linearModel)
Expand Down
28 changes: 13 additions & 15 deletions R/Data.R
Original file line number Diff line number Diff line change
Expand Up @@ -3,24 +3,18 @@
### `ModelEnv'

ModelEnvFormula <- function(formula, data = list(), subset = NULL,
na.action = NULL, frame = NULL,
na.action = NULL, frame = NULL,
enclos = sys.frame(sys.nframe()),
other = list(), designMatrix = TRUE,
responseMatrix = TRUE,
setHook=NULL, ...)
setHook = NULL, ...)
{

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
} else {
### we need to evaluate subset here since it
### might not be possible in `frame'
mf$subset <- subset
}

### NA-handling will for the ModelFrame objects later on...
mf$na.action <- stats::na.pass
Expand All @@ -31,15 +25,19 @@ ModelEnvFormula <- function(formula, data = list(), subset = NULL,

if (is.null(frame)) frame <- parent.frame()

mf$subset <- try(subset)
if (inherits(mf$subset, "try-error")) mf$subset <- NULL

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)
if (!use.subset) mf$subset <- NULL
mf$data <- data
mf$formula <- MEF@formula[[which]]
RET <- eval(mf, frame)
RET <- eval(mf, frame, enclos = enclos)
checkData(oldData, RET)
}
return(RET)
Expand All @@ -60,10 +58,8 @@ ModelEnvFormula <- function(formula, data = list(), subset = NULL,
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 (!use.subset) mf$subset <- NULL
MF <- eval(mf, frame, enclos = enclos)
if (exists(name, envir = envir, inherits = FALSE))
checkData(get(name, envir = envir, inherits = FALSE), MF)
assign(name, MF, envir = envir)
Expand All @@ -88,8 +84,10 @@ ModelEnvFormula <- function(formula, data = list(), subset = NULL,
}
MEapply(MEF, MEF@hooks$set, clone=FALSE)
}


use.subset <- TRUE
MEF@set(which = NULL, data = data, frame = frame)
use.subset <- FALSE

### handle NA's
if (!is.null(na.action))
Expand Down
47 changes: 47 additions & 0 deletions R/Generics.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,47 @@
#
# Copyright (C) 2006 Torsten Hothorn, Friedrich Leisch
# $Id: Generics.R 3126 2006-11-06 16:03:12Z hothorn $
#



## generics used in flexmix and flexclust which may also be useful in
## other packages

setGeneric("ICL", function(object, ...) standardGeneric("ICL"))

setGeneric("KLdiv", function(object, ...) standardGeneric("KLdiv"))

setGeneric("cluster", function(object, ...) standardGeneric("cluster"))

setGeneric("getModel", function(object, ...) standardGeneric("getModel"))

setGeneric("parameters", function(object, ...) standardGeneric("parameters"))

setGeneric("posterior", function(object, newdata, ...) standardGeneric("posterior"))

setGeneric("prior", function(object, ...) standardGeneric("prior"))

setGeneric("refit", function(object, ...) standardGeneric("refit"))

###**********************************************************

setGeneric("info",
function(object, which, ...) standardGeneric("info"))

setMethod("info", signature(object="ANY", which="missing"),
function(object, which, ...)
{
info(object, which="help")
})

infoCheck <- function(object, which, ...)
{
which %in% info(object, "help")
}



###**********************************************************


10 changes: 8 additions & 2 deletions inst/CHANGES
Original file line number Diff line number Diff line change
@@ -1,5 +1,11 @@
CHANGES IN `modeltools' VERSION 0.2-10

CHANGES IN `modeltools' VERSION 0.2-8
o Added several generic functions: ICL, KLdiv, cluster, getModel, parameters,
posterior, prior, refit, info, infoCheck

o fix problems with evaluating subset arguments

CHANGES IN `modeltools' VERSION 0.2-9

o the following code didn't work

Expand All @@ -9,7 +15,7 @@ CHANGES IN `modeltools' VERSION 0.2-8
a <- 1:10
b <- 1:10
stopifnot(identical(foo(a, b, subset = 1:5)@get("response")[[1]],1:5))
### was: couldn't find `y' when rame' wasn't specified
### was: couldn't find `y' when `frame' wasn't specified

x <- 1
y <- 2
Expand Down
49 changes: 49 additions & 0 deletions man/Generics.Rd
Original file line number Diff line number Diff line change
@@ -0,0 +1,49 @@
\name{Generics}
\alias{ICL}
\alias{KLdiv}
\alias{cluster}
\alias{getModel}
\alias{parameters}
\alias{posterior}
\alias{prior}
\alias{refit}
\title{Generic Utility Functions}
\description{
A collection of standard generic functions for which other packages
provide methods.
}
\usage{
ICL(object, \dots)
KLdiv(object, \dots)
cluster(object, \dots)
getModel(object, \dots)
parameters(object, \dots)
posterior(object, newdata, \dots)
prior(object, \dots)
refit(object, \dots)
}
\arguments{
\item{object}{S4 classed object.}
\item{newdata}{Optional new data.}
\item{\dots}{Some methods for these generic function may take
additional, optional arguments.}
}
\details{
\describe{
\item{ICL:}{Integrated Completed Likelihood criterion for model
selection.}
\item{KLdiv:}{Kullback-Leibler divergence.}
\item{cluster:}{Extract cluster membership information.}
\item{getModel:}{Get single model from a collection of models.}
\item{parameters:}{Get parameters of a model (similar to but more
general than \code{\link{coefficients}}).}
\item{posterior:}{Get posterior probabilities from a model or
compute posteriors for new data.}
\item{prior:}{Get prior probabilities from a model.}
\item{refit:}{Refit a model (usually to obtain additional
information that was not computed or stored during the initial
fitting process).}
}
}
\keyword{methods}
\author{Friedrich Leisch}
7 changes: 6 additions & 1 deletion man/ModelEnvFormula.Rd
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,8 @@
}
\usage{
ModelEnvFormula(formula, data = list(), subset = NULL,
na.action = NULL, frame = NULL, other = list(),
na.action = NULL, frame = NULL,
enclos = sys.frame(sys.nframe()), other = list(),
designMatrix = TRUE, responseMatrix = TRUE,
setHook = NULL, ...)
}
Expand All @@ -22,6 +23,10 @@ ModelEnvFormula(formula, data = list(), subset = NULL,
\item{na.action}{ a function which indicates what should happen when the data
contain \code{NA}'s. }
\item{frame}{ an optional environment \code{formula} is evaluated in. }
\item{enclos}{ specifies the enclosure passed to \code{\link{eval}} for
evaluating the model frame. The model frame is evaluated in
\code{envir = frame} with \code{enclos = enclos},
see \code{\link{eval}}.}
\item{other}{ an optional named list of additional formulae. }
\item{designMatrix}{ a logical indicating whether the design matrix
defined by the right hand side of \code{formula}
Expand Down
34 changes: 34 additions & 0 deletions man/info.Rd
Original file line number Diff line number Diff line change
@@ -0,0 +1,34 @@
%
% Copyright (C) 2005 Friedrich Leisch
% $Id: info.Rd 1849 2005-10-10 06:15:57Z leisch $
%
\name{info}
\alias{info}
\alias{infoCheck}
\alias{info,ANY,missing-method}
\title{Get Information on Fitted Objects}
\description{
Returns descriptive information about fitted objects.}
}
\usage{
info(object, which, ...)
\S4method{info}{ANY,missing}(object, which, ...)
infoCheck(object, which, ...)
}
\arguments{
\item{object}{fitted object.}

\item{which}{which information to get. Use \code{which="help"} to list
available information.}

\item{\dots}{passed to methods.}
}
\details{
Function \code{info} can be used to access slots of fitted
objects in a portable way.

Function \code{infoCheck} returns a logical value that is \code{TRUE}
if the requested information can be computed from the \code{object}.
}
\author{Friedrich Leisch}
\keyword{methods}
15 changes: 14 additions & 1 deletion tests/regtest.R
Original file line number Diff line number Diff line change
Expand Up @@ -45,11 +45,24 @@ stopifnot(nrow(x) == 10 && all(x[,1] == 1))
### bugfix: subset was not correctly interpreted in `frame'
tmp <- function(formula, data = list(), subset = NULL)
ModelEnvFormula(formula, data, subset = subset, frame = parent.frame())
foo <- function(x, y, ...) tmp(y ~ x, ...)
foo <- function(x, y, subset, ...) tmp(y ~ x, subset = subset, ...)
a <- 1:10
b <- 1:10
stopifnot(identical(foo(a, b, subset = 1:5)@get("response")[[1]],1:5))

x <- 1
y <- 2
stopifnot(identical(foo(a, b, subset = 1:5)@get("response")[[1]],1:5))

### subset problems
menv <- ModelEnvFormula(Species ~ ., data = iris,
subset = (iris$Species != "virginica"))
stopifnot(nrow(menv@get("input")) == 100)
stopifnot(nrow(menv@get("input", data = iris)) == 150)

menv <- ModelEnvFormula(Species ~ ., data = iris,
subset = (iris$Species != "virginica"),
keep.subset = TRUE)
stopifnot(nrow(menv@get("input")) == 100)
stopifnot(nrow(menv@get("input", data = iris)) == 150)

0 comments on commit 09ecbcf

Please sign in to comment.