[Lme4-commits] r1534 - branches/roxygen/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Jan 29 00:27:32 CET 2012
Author: dmbates
Date: 2012-01-29 00:27:32 +0100 (Sun, 29 Jan 2012)
New Revision: 1534
Modified:
branches/roxygen/R/lmList.R
Log:
Change S4 methods for generics in stats to S3 methods.
Modified: branches/roxygen/R/lmList.R
===================================================================
--- branches/roxygen/R/lmList.R 2012-01-28 23:26:56 UTC (rev 1533)
+++ branches/roxygen/R/lmList.R 2012-01-28 23:27:32 UTC (rev 1534)
@@ -70,59 +70,56 @@
new("lmList", val, call = mCall, pool = pool)
}
-
-setMethod("coef", signature(object = "lmList"),
+##' @importFrom stats coef
+##' @S3method coef lmList
## Extract the coefficients and form a data.frame if possible
- function(object, augFrame = FALSE, data = NULL,
- which = NULL, FUN = mean, omitGroupingFactor = TRUE, ...)
- {
- coefs <- lapply(object, coef)
- non.null <- !unlist(lapply(coefs, is.null))
- if (sum(non.null) > 0) {
- template <- coefs[non.null][[1]]
- if (is.numeric(template)) {
- co <- matrix(template,
- ncol = length(template),
- nrow = length(coefs),
- byrow = TRUE,
- dimnames = list(names(object), names(template)))
- for (i in names(object)) {
- co[i,] <- if (is.null(coefs[[i]])) { NA } else coefs[[i]]
- }
- coefs <- as.data.frame(co)
- effectNames <- names(coefs)
- if(augFrame) {
- if (is.null(data)) {
- data <- getData(object)
- }
- data <- as.data.frame(data)
- if (is.null(which)) {
- which <- 1:ncol(data)
- }
- data <- data[, which, drop = FALSE]
- ## eliminating columns with same names as effects
- data <- data[, is.na(match(names(data), effectNames)), drop = FALSE]
- data <- gsummary(data, FUN = FUN, groups = getGroups(object))
- if (omitGroupingFactor) {
- data <- data[, is.na(match(names(data),
- names(getGroupsFormula(object,
- asList = TRUE)))),
- drop = FALSE]
- }
- if (length(data) > 0) {
- coefs <- cbind(coefs, data[row.names(coefs),,drop = FALSE])
- }
- }
- attr(coefs, "level") <- attr(object, "level")
- attr(coefs, "label") <- "Coefficients"
- attr(coefs, "effectNames") <- effectNames
- attr(coefs, "standardized") <- FALSE
- #attr(coefs, "grpNames") <- deparse(getGroupsFormula(object)[[2]])
- #class(coefs) <- c("coef.lmList", "ranef.lmList", class(coefs))
- }
- }
- coefs
- })
+coef.lmList <- function(object, augFrame = FALSE, data = NULL,
+ which = NULL, FUN = mean, omitGroupingFactor = TRUE, ...) {
+ coefs <- lapply(object, coef)
+ non.null <- !unlist(lapply(coefs, is.null))
+ if (sum(non.null) > 0) {
+ template <- coefs[non.null][[1]]
+ if (is.numeric(template)) {
+ co <- matrix(template,
+ ncol = length(template),
+ nrow = length(coefs),
+ byrow = TRUE,
+ dimnames = list(names(object), names(template)))
+ for (i in names(object)) {
+ co[i,] <- if (is.null(coefs[[i]])) { NA } else coefs[[i]]
+ }
+ coefs <- as.data.frame(co)
+ effectNames <- names(coefs)
+ if(augFrame) {
+ if (is.null(data)) {
+ data <- getData(object)
+ }
+ data <- as.data.frame(data)
+ if (is.null(which)) {
+ which <- 1:ncol(data)
+ }
+ data <- data[, which, drop = FALSE]
+ ## eliminating columns with same names as effects
+ data <- data[, is.na(match(names(data), effectNames)), drop = FALSE]
+ data <- gsummary(data, FUN = FUN, groups = getGroups(object))
+ if (omitGroupingFactor) {
+ data <- data[, is.na(match(names(data),
+ names(getGroupsFormula(object,
+ asList = TRUE)))),
+ drop = FALSE]
+ }
+ if (length(data) > 0) {
+ coefs <- cbind(coefs, data[row.names(coefs),,drop = FALSE])
+ }
+ }
+ attr(coefs, "level") <- attr(object, "level")
+ attr(coefs, "label") <- "Coefficients"
+ attr(coefs, "effectNames") <- effectNames
+ attr(coefs, "standardized") <- FALSE
+ }
+ }
+ coefs
+}
pooledSD <- function(x, ...)
{
@@ -144,6 +141,8 @@
val
}
+##' @importFrom methods show
+##' @exportMethod show
setMethod("show", signature(object = "lmList"),
function(object)
{
@@ -163,6 +162,7 @@
}
})
+##' @S3method confint lmList
confint.lmList <- function(object, parm, level = 0.95, ...)
{
mCall <- match.call()
@@ -253,26 +253,28 @@
}, ...)
}
-setMethod("update", signature(object = "lmList"),
- function(object, formula., ..., evaluate = TRUE)
- {
- call <- object at call
- if (is.null(call))
- stop("need an object with call slot")
- extras <- match.call(expand.dots = FALSE)$...
- if (!missing(formula.))
- call$formula <- update.formula(formula(object), formula.)
- if (length(extras) > 0) {
- existing <- !is.na(match(names(extras), names(call)))
- for (a in names(extras)[existing]) call[[a]] <- extras[[a]]
- if (any(!existing)) {
- call <- c(as.list(call), extras[!existing])
- call <- as.call(call)
- }
- }
- if (evaluate)
- eval(call, parent.frame())
- else call
- })
+##' @importFrom stats update
+##' @S3method update lmList
+update.lmList <- function(object, formula., ..., evaluate = TRUE) {
+ call <- object at call
+ if (is.null(call))
+ stop("need an object with call slot")
+ extras <- match.call(expand.dots = FALSE)$...
+ if (!missing(formula.))
+ call$formula <- update.formula(formula(object), formula.)
+ if (length(extras) > 0) {
+ existing <- !is.na(match(names(extras), names(call)))
+ for (a in names(extras)[existing]) call[[a]] <- extras[[a]]
+ if (any(!existing)) {
+ call <- c(as.list(call), extras[!existing])
+ call <- as.call(call)
+ }
+ }
+ if (evaluate)
+ eval(call, parent.frame())
+ else call
+}
+##' @importFrom stats formula
+##' @S3method formula lmList
formula.lmList <- function(x, ...) x at call[["formula"]]
More information about the Lme4-commits
mailing list