Commit 89dc07f6 by Eric Coissac

Adds to the vars.procmod function the hability to deal with interactions in the model

parent a99f38d8
......@@ -97,7 +97,6 @@ model.procmod.default = function (formula,
xlev = NULL,
...)
{
possible_newdata = !missing(data) &&
is.procmod.frame(data) &&
identical(substitute(data),
......@@ -267,6 +266,8 @@ model.procmod.default = function (formula,
data
}
#' Plays the role of model.matrix in classical lm
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
......@@ -291,6 +292,95 @@ vars.procmod = function(object, data = environment(object),
attr(data,"response")=attr(t, "response")
factors = attr(t,"factors")
if(any(colSums(factors)>1)) {
interactions = factors[,colSums(factors)>1,drop=FALSE]
i.labels = colnames(interactions)
i.factors=data[apply(interactions,
1,
any)]
resp = data[[attr(t, "response")]]
XYs <- lapply(i.factors,function(x) crossprod(resp, x))
sol_yxs <- lapply(XYs,svd)
A_xys <- lapply(sol_yxs, function(x) x$v %*% t(x$u))
Xrots <- mapply(function(x,a) x %*% a,
i.factors,A_xys,
SIMPLIFY = FALSE)
for (i in seq_len(ncol(interactions))) {
inter = names(which(interactions[,i] >0))
i.val=Xrots[[inter[1]]]
for (j in inter[-1]) {
i.val = i.val * Xrots[[j]]
}
data[[i.labels[i]]] = i.val
}
}
return(data)
}
model.matrix.pm = 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.procmod.default(object, data, xlev = xlev)
else {
deparse2 <- function(x) paste(deparse(x, width.cutoff = 500L),
collapse = " ")
reorder <- match(vapply(attr(t, "variables"), deparse2,
"")[-1L], names(data))
if (anyNA(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")
if (length(data)) {
contr.funs <- as.character(getOption("contrasts"))
namD <- names(data)
for (i in namD) if (is.character(data[[i]]))
data[[i]] <- factor(data[[i]])
isF <- vapply(data, function(x) is.factor(x) || is.logical(x),
NA)
isF[int] <- FALSE
isOF <- vapply(data, is.ordered, NA)
for (nn in namD[isF]) if (is.null(attr(data[[nn]], "contrasts")))
contrasts(data[[nn]]) <- contr.funs[1 + isOF[nn]]
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[["x"]] <- raw(nrow(data))
}
ans <- .External2(C_modelmatrix, t, data)
cons <- if (any(isF))
lapply(data[isF], attr, "contrasts")
attr(ans, "contrasts") <- cons
ans
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment