# inst/dev-codes/makeFun.R In nlmrt: Functions for Nonlinear Least Squares Solutions (Deprecated!)

```#' Create a function from a formula
#'
#' Provides an easy mechanism for creating simple "mathematical"
#' functions via a formula interface.
#'
#' @param object an object from which to create a function.  This should generally
#'         be specified without naming.
#' @param \dots additional arguments in the form \code{var = val} that
#' set default values for the inputs to the function.
#' @return a function
#'
#' @details
#' The definition of the function is given by the left side of a formula.  The right
#' side lists at least one of the inputs to the function.
#' The inputs to the function are all variables appearing on either the left
#' or right sides of the formula.  Those appearing in the right side will
#' occur in the order specified.  Those not appearing in the right side will
#' appear in an unspecified order.
#'
#' @examples
#' f <- makeFun( sin(x^2 * b) ~ x & y & a); f
#' g <- makeFun( sin(x^2 * b) ~ x & y & a, a=2 ); g
#' h <- makeFun( a * sin(x^2 * b) ~ b & y, a=2, y=3); h

setGeneric(
"makeFun",
function( object, ... )
{
standardGeneric('makeFun')
}
)

#' @rdname makeFun
#' @aliases makeFun,formula-method
#' @param strict.declaration  if \code{TRUE} (the default), an error is thrown if
#' default values are given for variables not appearing in the \code{object} formula.

setMethod(
'makeFun',
'formula',
function( object, ..., strict.declaration =TRUE ) {
sexpr <- object
if (! inherits( sexpr, "formula") || length(sexpr) != 3)
stop('First argument must be a formula with both left and right sides.')

vals <- list(...)
expr <- eval(sexpr)  # not sure if eval() is needed here or not.
lhs <- lhs(expr) # expr[[2]]
rhs <- rhs(expr)  # expr[[3]]

rhsVars <- all.vars(rhs)
lhsOnlyVars <- setdiff(all.vars(lhs), rhsVars)
lhsOnlyVars <- setdiff(lhsOnlyVars,'pi')    # don't treat pi like a variable
vars <- c(rhsVars, lhsOnlyVars)
unDeclaredVars <- setdiff(names(vals), vars)
declaredVars <- setdiff(vars, unDeclaredVars)
if (length( unDeclaredVars ) != 0) {
if (strict.declaration)
stop(paste( "Default values provided for undeclared variables:",
paste(unDeclaredVars, collapse=",")
))
vars <- declaredVars
}

valVec <- rep("", length(vars))
names(valVec) <- vars
for( n in intersect(vars, names(vals)) ) valVec[n] <- as.character(vals[n])

result <- function(){}
body(result) <- parse( text=deparse(lhs) )
formals(result) <-
eval(parse(
text=paste( "as.pairlist(alist(",
paste(vars, "=", valVec, collapse=",", sep=""), "))"
)
))
environment(result) <- environment(object) # parent.frame()

return(result)
}
)

#' @rdname makeFun
#' @aliases makeFun,lm-method
#' @examples
#' model <- lm(wage ~ poly(exper,degree=2), data=CPS)
#' fit <- makeFun(model)
#' xyplot(wage ~ exper, data=CPS)

setMethod(
'makeFun',
'lm',
function( object, ... ) {
vars <- model.vars(object)
result <- function(){}
if ( length( vars ) <  1 ) {
result <- function( ... ) {
dots <- list(...)
if (length(dots) > 0) {
x <- dots[[1]]
dots[[1]] <- NULL
} else {
x <- 1
}
do.call(predict, c(list(model, newdata=data.frame(x=x)), dots))
}
} else {
body(result) <-
parse( text=paste(
"return(predict(model, newdata=data.frame(",
paste(vars, "= ", vars, collapse=",", sep=""),
"), ...))"
)
)
formals(result) <-
eval(parse(
text=paste( "as.pairlist(alist(",
paste(vars, "= ",  collapse=",", sep=""), ", ...=))"
)
))
}

# myenv <- parent.frame()
# myenv\$model <- object
# environment(result) <- myenv
environment(result) <- list2env( list(model=object) )
return(result)
}
)

#' extract predictor variables from a model
#'
#' @param model a model, typically of class \code{lm} or \code{glm}
#' @return a vector of variable names
#' @examples
#' model <- lm( wage ~ poly(exper,degree=2), data=CPS )
#' model.vars(model)
model.vars <- function(model) {
formula <- as.formula(model\$call\$formula)
all.vars(rhs(formula))
}
```

## Try the nlmrt package in your browser

Any scripts or data that you put into this service are public.

nlmrt documentation built on Sept. 19, 2017, 3 a.m.