Dear experts:
Is it possible to create a new function based
on stats:::model.matrix.default so that an alternative factor coding is used
when the function is called instead of the default factor coding?
Basically, I'd like to reproduce the results in 'mat' below, without having
to explicitly specify my desired factor coding (identity matrices) in the
'contrasts.arg'.
dd <- data.frame(a = gl(3,4), b = gl(4,1,12))
ca <- contrasts(dd$a, contrasts= FALSE) # 3 x 3 identity matrix
cb <- contrasts(dd$b, contrasts= FALSE) # 4 x 4 identity matrix
mat <- model.matrix(~ a + b, dd, contrasts.arg = list(a=ca, b=cb))
My approach was to modify the code in model.matrix by explicitly setting the
contrasts argument in the contr.identity and contrasts function to FALSE.
This is shown at the bottom of the email in the function model.matrix2:
contr.identity <- contr.treatment
formals(contr.identity)$contrasts <- FALSE
contrasts <- contrasts
formals(contrasts)$contrasts <- FALSE
However, I believe this function is using contrasts = TRUE, as it doesn't
return the identity contrasts
mat2 <- model.matrix2(~ a + b, dd)
Any help here is much appreciated.
Axel.
-----------------------------------------------------------------------------
model.matrix2 <-
function (object, data = environment(object), contrasts.arg = NULL,
xlev = NULL, ...)
{
t <- if (missing(data))
terms(object)
else terms(object, data = data)
if (is.null(attr(data, "terms")))
data <- model.frame(object, data, xlev = xlev)
else {
reorder <- match(sapply(attr(t, "variables"), deparse,
width.cutoff = 500)[-1L], names(data))
if (any(is.na(reorder)))
stop("model frame and formula mismatch in model.matrix()")
if (!identical(reorder, seq_len(ncol(data))))
data <- data[, reorder, drop = FALSE]
}
int <- attr(t, "response")
contr.identity <- contr.treatment
formals(contr.identity)$contrasts <- FALSE
contrasts <- contrasts
formals(contrasts)$contrasts <- FALSE
if (length(data)) {
contr.funs <- c('contr.identity', 'contr.poly')
namD <- names(data)
for (i in namD) if (is.character(data[[i]])) {
data[[i]] <- factor(data[[i]])
warning(gettextf("variable '%s' converted to a factor",
i), domain = NA)
}
isF <- sapply(data, function(x) is.factor(x) || is.logical(x))
isF[int] <- FALSE
isOF <- sapply(data, is.ordered)
for (nn in namD[isF]) if (is.null(attr(data[[nn]], "contrasts")))
contrasts(data[[nn]]) <- contr.funs[1 + isOF[nn]]
# browser()
if (!is.null(contrasts.arg) && is.list(contrasts.arg)) {
if (is.null(namC <- names(contrasts.arg)))
stop("invalid 'contrasts.arg' argument")
for (nn in namC) {
if (is.na(ni <- match(nn, namD)))
warning(gettextf("variable '%s' is absent, its contrast
will be ignored",
nn), domain = NA)
else {
ca <- contrasts.arg[[nn]]
if (is.matrix(ca))
contrasts(data[[ni]], ncol(ca)) <- ca
else contrasts(data[[ni]]) <- contrasts.arg[[nn]]
}
}
}
}
else {
isF <- FALSE
data <- list(x = rep(0, nrow(data)))
}
ans <- .Internal(model.matrix(t, data))
cons <- if (any(isF))
lapply(data[isF], function(x) attr(x, "contrasts"))
else NULL
attr(ans, "contrasts") <- cons
ans
}
[[alternative HTML version deleted]]
______________________________________________
R-help@r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-help
PLEASE do read the posting guide http://www.R-project.org/posting-guide.html
and provide commented, minimal, self-contained, reproducible code.
