formula-based interface for tgp

tgpF.R

un.model.matrix <- function(partial, frml, df) {
  mf <- model.frame(terms.formula(frml), df)
  fullDesign <- model.matrix(terms.formula(frml), df)

  if (ncol(partial) != ncol(fullDesign))
      stop('ncol(partial) != ncol(fullDesign)')

  asgn <- attr(fullDesign, 'assign')
  cs <- attr(fullDesign, 'contrasts')
  j <- 0
  output <- lapply(seq_len(max(asgn)), function(i)
   if ( ! class(mf[[i]]) %in% c('factor','character') ) {
   output <- data.frame(partial[ , asgn == i])
  } else { # have a factor
   j <<- j+1
   column <- eval(parse(text=names(cs)[j]), df)
   contrastM <- do.call(cs[[j]], list(unique(column)))
   contrastV <- do.call(paste0, data.frame(contrastM))
   partialI <- do.call(paste0,
                       data.frame(partial[ , asgn == i ]))
   rownames(contrastM)[ match(partialI, contrastV) ]
  })
  output <- do.call(cbind, output)
  names(output) <- names(mf)
  output
}

# formula-based tgp.design
tgp.designF <- function(n, fittedModel) {
  formula <- fittedModel$call$formula[c(1,3)]
  data <- fittedModel$data
  if (is.null(data)) data <- eval(fittedModel$call$data)
  if ( ! class(fittedModel) %in% 'tgp' )
    stop('fitted model must have class tgp')

  mm <- model.matrix(terms.formula(formula), data)
  un.model.matrix(tgp.design(n, mm, fittedModel),
                  formula,
                  data)
}

tgpF <- function( formula, data, btgpllmFun =btlm, keepData=T, ... ) {
  if (length(formula) != 3) stop('invalid formula:', formula,
                                 ' needs to look like y ~ x1 + x2')
  X <- model.matrix(formula, data)
  Zformula <- formula[c(1,2)]
  Z <- model.matrix(Zformula, data)
  r <- do.call(btgpllmFun, c(list(X=X, Z=Z), list(...)))
  r$call <- match.call()
  if(keepData) r$data <- data
  r
}