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