1

我有一个模型构建函数，其中公式可以包含一些函数，我希望它能够工作，以便如果用户多次输入该函数，只有第一次使用时会发出警告。例如，lm如果我们两次使用相同的变量，则第二个被删除：

y<-1:3
x<-1:3 
lm(y~x+x)

Call:
lm(formula = y ~ x + x)

Coefficients:
(Intercept)            x  
          0            1

这是有效的，因为terms用于model.frame删除具有相同名称的变量的函数。但在我的情况下，我正在使用公式内部的函数，这些函数不一定具有相同的参数列表，我希望这种行为能够扩展，以便这些函数的参数无关紧要：

model(y~x+fn("x"))
  (Intercept) x temp
1           1 1    1
2           1 2    1
3           1 3    1
model(y~x+fn("x")+fn("x")) #identical function calls
  (Intercept) x temp
1           1 1    1
2           1 2    1
3           1 3    1
model(y~x+fn("x")+fn("z")) #function with different argument value
Error in attr(all_terms, "variables")[[1 + ind_fn]] : 
  subscript out of bounds

这是我在上面使用的示例函数（高度简化）：

model <- function(formula, data) {    

  #the beginning is pretty much copied from lm function    
  mf <- match.call(expand.dots = FALSE)   
  mf <- mf[c(1L,  match(c("formula", "data"), names(mf), 0L))]
  mf[[1L]] <- as.name("model.frame")
  mf$na.action <- as.name("na.pass")  

  all_terms <- if (missing(data)){ 
    terms(formula, "fn")
  } else terms(formula, "fn", data = data)

  #find the position of the function call in the formula
  ind_fn <- attr(all_terms, "specials")$fn

  #update the formula by removing the "fn" part
  if(!is.null(ind_fn)){
    fn_term <- attr(all_terms, "variables")[[1 + ind_fn]]
    formula <- update( formula, paste(". ~ .-", deparse(fn_term, 
                       width.cutoff = 500L, backtick = TRUE)))  
     mf$formula<-formula           
  } 

  # build y and X
  mf <- eval(mf, parent.frame())   
  y <- model.response(mf, "numeric")
  mt <- attr(mf, "terms")
  X <- model.matrix(mt, mf)


  #if fn was in formula do something with it
  if (!is.null(ind_fn)){

    foobar<-function(type=c("x","z")){
      if(type=="x"){
        rep(1,nrow(X))
      } else rep(0,nrow(X))
    }
    fn_term[[1]]<-as.name("foobar") 
    temp<-eval(fn_term)
    X<-cbind(X,temp)
  }  

  X
  }

我可以检查特价商品（函数调用）的名称并将它们重命名为与第一次出现的相同，但我想知道是否有更聪明的方法来处理这个问题？

4

1 回答 1

1

我无法让你的代码正常工作，但假设我已经理解你的任务，也许这样的事情可以完成你所追求的。

f <- y ~ x + fn("x") + fn("z") + z + fn('a')
# get list of terms
vars <- as.list(attr(terms(f), 'variables'))
# get those terms that are duplicate calls
redundant <- vars[sapply(vars, is.call) & duplicated(sapply(vars, function(x) as.list(x)[[1]]))]
# remove the duplicate calls from the formula
update(f, paste(". ~ .", paste(sapply(redundant, deparse), collapse='-'), sep='-'))
# y ~ x + fn("x") + z
于 2013-03-21T15:22:58.923 回答