1formula2coefs <- function(obj,fo,warn=FALSE){
2    if(length(fo)>2)
3        rhs <- fo[-2]
4    else
5        rhs <- fo
6    xlevels <- get_xlevels(obj)
7    tm <- terms(rhs)
8    termlabs <- attr(tm,"term.labels")
9    o.tm <- terms(obj)
10    o.termlabs <- attr(o.tm,"term.labels")
11    if(!all(termlabs%in%o.termlabs)){
12        sdf <- setdiff(termlabs,o.termlabs)
13        if(warn)
14            warning(paste(paste(sdf,collapse=", "),"not in model"))
15        termlabs <- intersect(termlabs,o.termlabs)
16    }
17    names <- lapply(termlabs,tl2coefs,xlevels=xlevels)
18    names <- unlist(names)
19    names <- unique(names)
20    return(names)
21}
22
23formula2termlabs <- function(obj,fo,warn=FALSE){
24    if(length(fo)>2)
25        rhs <- fo[-2]
26    else
27        rhs <- fo
28    tm <- terms(rhs)
29    termlabs <- attr(tm,"term.labels")
30    o.tm <- terms(obj)
31    o.termlabs <- attr(o.tm,"term.labels")
32    if(!all(termlabs%in%o.termlabs)){
33        sdf <- setdiff(termlabs,o.termlabs)
34        if(warn)
35            warning(paste(paste(sdf,collapse=", "),"not in model"))
36        termlabs <- intersect(termlabs,o.termlabs)
37    }
38    return(termlabs)
39}
40
41
42tl2coefs <- function(tl,xlevels){
43    tl <- unlist(strsplit(tl,":"))
44    nms <- lapply(tl,tl2coefs_,xlevels=xlevels)
45    if(length(tl)>1)
46        nms <- Reduce(intercoefs,nms)
47    return(nms)
48}
49
50tl2coefs_ <- function(tl,xlevels){
51    if(!(tl %in% names(xlevels)))
52        return(tl)
53    else {
54        levs <- xlevels[[tl]]
55        return(paste0(tl,levs))
56    }
57}
58
59intercoefs <- function(x,y){
60    outer(x,y,paste,sep=":")
61}
62
63get_xlevels <- function(obj) {
64    if("xlevels" %in% names(obj))
65        obj$xlevels
66    else {
67        xlevels <- list()
68        Contr <- names(attr(model.matrix(obj), "contrasts"))
69        for (c in Contr) xlevels[[c]] <- levels(obj@frame[,c])
70        xlevels
71    }
72}
73