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]]

