  I need help debugging a general formula interpreter that is now
central to the dozen or so functions in my libraries that handle
nonlinear regression. Take a look at the examples below then throw
your favourite formulae at it to see if you can break it!
  For the R hackers, the function currently does not handle parameter
names referring to vectors nor to formulae embedded in a formula (such
as a linear part defined by Wilkinson and Rogers notation within a
nonlinear formula).
  Try writing this sort of function with S-Plus...
  The docs and function follow. Thanks for the help. Jim

----------------------------------------------------------------------
\name{finterp}
\title{Formula interpreter}
\usage{
finterp(z, envir=sys.frame(sys.parent()), formula=FALSE,
	vector=TRUE, start=1)
}
\arguments{
\item{z}{A model formula beginning with ~, either in Wilkinson and
Rogers notation or containing unknown parameters.}
\item{envir}{The environment in which the formula is to be
interpreted.}
\item{formula}{If TRUE and the formula is in Wilkinson and Rogers
notation, just returns the formula.}
\item{vector}{If FALSE and the formula contains unknown parameters,
the function returned has them as separate arguments, if TRUE, it has
one argument, the unknowns as a vector.}
\item{start}{The starting index value of the parameter vector in the
function returned.}
}
\description{
\code{finterp} translates a model formula into a function of the
unknown parameters or of a vector of them. Such language formula can
either be in Wilkinson and Rogers notation or be expressions
containing both known (existing) covariates and unknown (not existing)
parameters. In the latter, factor variables cannot be used and
parameters must be scalars. The covariates in the formula are sought
in the environment provided.
}
\value{
A function of the unknown parameters or of a vector of them is
returned. Its attributes give the formula supplied, the model
function produced, the covariate names, the parameter names, and the
range of values of the index of the parameter vector. If
\code{formula} is TRUE and a Wilkinson and Rogers formula was
supplied, it is returned instead of a function.
}
\examples{
x1 <- rpois(20,2)
x2 <- rnorm(20)
#
# Wilkinson and Rogers formula with three parameters
fn1 <- finterp(~x1+x2)
fn1
fn1(rep(2,3))
# the same formula with unknowns
fn2 <- finterp(~b0+b1*x1+b2*x2)
fn2
fn2(rep(2,3))
#
# nonlinear formulae with unknowns
# log link
fn2a <- finterp(~exp(b0+b1*x1+b2*x2))
fn2a
fn2a(rep(0.2,3))
# compartment model
times <- 1:20
# exp() parameters to ensure that they are positive
fn3 <- finterp(~exp(volume)*exp(absorption)/(exp(absorption)-
	exp(elimination))*(exp(-exp(elimination)*times)-
	exp(-exp(absorption)*times)))
fn3
fn3(log(c(3,0.3,0.2)))
#
# Poisson density
y <- rpois(20,5)
fn4 <- finterp(~mu^y*exp(-mu)/gamma(y+1))
fn4
fn4(5)
dpois(y,5)
#
# Poisson likelihood
fn5 <- finterp(~-y*log(mu)+mu+lgamma(y+1),vector=F)
fn5
likefn1 <- function(p) sum(fn5(p))
nlm(likefn1,p=1)
mean(y)
#
# likelihood for Poisson log linear regression
y <- rpois(20,fn2a(c(0.2,1,0.4)))
nlm(likefn1,p=1)
mean(y)
likefn2 <- function(p) sum(fn5(mu=fn2a(p)))
nlm(likefn2,p=c(1,0,0))
#
# likelihood for Poisson nonlinear regression
y <- rpois(20,fn3(log(c(3,0.3,0.2))))
nlm(likefn1,p=1)
mean(y)
likefn3 <- function(p) sum(fn5(mu=fn3(p)))
nlm(likefn3,p=log(c(1,0.4,0.1)))
}

------------------------------------------------------------------------
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1999 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#   finterp(z, envir=sys.frame(sys.parent()), formula=FALSE,
#	parameters=FALSE, start=1)
#
#  DESCRIPTION
#
#    Function to translate a model formula with unknown parameters
#  into a function.

finterp <- function(z, envir=sys.frame(sys.parent()), formula=FALSE,
	vector=TRUE, start=1){
	if(!inherits(z,"formula"))return(NULL)
	ch1 <- deparse(z[[length(z)]])
	i <- un <- fcn <- ex <- ch <- par <- NULL
	for(i in 1:length(ch1))ch <- paste(ch,ch1[i],collapse=" ")
	mem <- strsplit(gsub("(\\[(0|1|2|3|4|5|6|7|8|9|:|,)+\\])|([][+*/^():!<>%&|~,-])|( [0-9]+)|(^[0-9]+)"," ",ch)," ")[[1]]
	if(length(mem)>0){
		for(i in 1:length(mem)){
			ex <- c(ex,exists(mem[i],envir=envir))
			fcn <- c(fcn,if(exists(mem[i]))
				is.function(eval(parse(text=mem[i])))
				else F)}
		un <- unique(mem[!ex])
		if(length(unique(mem[ex&!fcn]))==0&&length(un)==0)
			stop("finterp: no variables found")}
	if(is.null(ex)||all(ex)){
		if(formula)return(z)
		else {
			mt <- terms(z)
			if(is.numeric(mt[[2]]))dm <- matrix(1)
			else dm <- model.matrix(mt,model.frame(mt,envir))
			.fn <- function(.p) as.vector(attr(.fn,"model")%*%
				.p[attr(.fn,"range")[1]:attr(.fn,"range")[2]])
			attributes(.fn) <- list(formula=z,model=dm,
				covariates=if(length(mem)>0)
					unique(mem[ex&!fcn]) else NULL,
				parameters=paste("p[",1:ncol(dm),"]",sep=""),
				range=c(start,start+ncol(dm)-1),
				class="formulafn")
			rm(z,envir,formula,vector,start,ch1,ch,mem,fcn,ex,i,dm,un,par,mt)
			return(.fn)}}
	.fn <- function(.p) eval(attr(.fn,"model"))
	if(vector){
		ch <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",ch)))
		ch <- gsub("-","- ",gsub("/"," / ",ch))
		ch <- paste(" ",gsub("\\(","( ",ch)," ",sep="")
		for(i in 1:length(un))ch <- gsub(paste(" ",un[i]," ",sep=""),
			paste(" .p[",start+i-1,"] ",sep=""),ch)}
	else {
		par <- "alist("
		for(i in 1:length(un)){
			if(i>1)par <- paste(par,",",collapse="")
			par <- paste(par,un[i],"=",collapse="")}
# bug in 0.63.3
		if(length(un)==1)par <- paste(par,",...=",collapse="")
		par <- paste(par,")",collapse="")
		formals(.fn) <- eval(parse(text=par))}
	attributes(.fn) <- list(formula=z,model=parse(text=ch),parameters=un,
		covariates=unique(mem[ex&!fcn]),
		range=c(start,start+length(un)-1),class="formulafn")
	rm(z,envir,formula,start,vector,ch1,ch,mem,fcn,ex,i,un,par)
	return(.fn)}

print.formulafn <- function(z){
	cat("\nformula:\n")
	print.default(unclass(attr(z,"formula")))
	cat("\n")
	if(!is.matrix(attr(z,"model"))){
		model <- deparse(attr(z,"model"))
		model[1] <- sub("expression","",model[1])
		cat(paste("model function:\n"))
		cat(model,sep="\n",collapse="")}
	if(length(attr(z,"covariates"))>0){
		cat(paste("covariates:\n"))
		for(i in 1:length(attr(z,"covariates")))
			cat(attr(z,"covariates")[i]," ")
		cat("\n\n")}
	cat(paste("parameters:\n"))
	for(i in 1:length(attr(z,"parameters")))cat(attr(z,"parameters")[i]," ")
	cat("\n")}

model <- function(z, ...) UseMethod("model")

model.formulafn <- function(z) attr(z,"model")

formula.formulafn <- function(z) attr(z,"formula")

covariates.formulafn <- function(z) attr(z,"covariates")

parameters <- function(z, ...) UseMethod("parameters")

parameters.formulafn <- function(z) attr(z,"parameters")
-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
r-help mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
Send "info", "help", or "[un]subscribe"
(in the "body", not the subject !)  To: r-help-request@stat.math.ethz.ch
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._

