# Function "ktsolve" . This document is copyright 2010 by Carl Witthoft. # Permission given to copy and modify as desired so long as the document # or derivative works are not sold or made part of a commercial product. # Please contact the author, carl@witthoft.com, for permission to # include in a specified commercial package. # # Definitions: # known -- list or vector of known values. The elements must be named # and the names must match variable names in yfunc. # guess -- list or vector of initial guesses for the unknown values. S ame rules as for 'known,' AND length(guess) # must be same as number of y[j] equations in yfunc, to avoid over- or under-defined system. # yfunc -- is a function of the form: # yfunc<-function(x) { # y<-vector() # y[1]<-f1(x) # y[2]<-f2(x) # y[length(x)]<-fn(x) # y # } # where y[j] are dummies which will be driven to zero, # and x[j] is a dummy vector which will be filled in with 'guess' # So, eqns in the form A=f(x) must be entered as y[j] <- f(x)-A # Example: d = a + sqrt(b) and a = sin(a/b) + g*exp(f*a) become # y[1]<- a - d +sqrt(b) and y[2]<- sin(a/b) +g*exp(f*a) -a , # and e.g. # known <- list(a=3,d=5,g=.1) are the fixed parameters and # guess <- list(b=1,f=1) are the initializers for BBsolve() . # # Oh, and BTW the function name is an homage to my alltime favorite # app: TK!Solver # ktsolve<-function(yfunc,known,guess){ require(BB) # length(body(y)) is one greater than number of lines due to"{}" # first, assign the 'known' values for (i in 1:length(known)) { if(length(grep(names(known)[i], body(yfunc)[-1]))<1) warning("Input '", names(known)[i], '" not found in func') # make a search string which distinguishes a variable from part of a string lookfor<-paste("\\b",names(known)[i],"\\b",sep="",collapse="") parse(text=gsub(lookfor,known[i],body(yfunc)[-1])) -> body(yfunc)[-1] } # Now reconfigure yfunc's body to have x[n] for each 'guess' name for (i in 1:length(guess)) { if(length(grep(names(guess)[i], body(yfunc)[-1]))<1) warning("Guess '", names(guess)[i],"' not found in func") subpat<-paste("x\\[",i,"\\]",sep="") lookfive<-paste("\\b",names(guess)[i],"\\b",sep="",collapse="") parse(text=gsub(lookfive, subpat, body(yfunc)[-1])) -> body(yfunc)[-1] } # are yfunc and guess same length? (yfunc() fails if guess is shorter) # Also, yfunc() fails if any undefined values, which is helpful if(length(yfunc(unlist(guess)))bbsolution #too lazy to make nice formatted table cat('solution is:\n') print(bbsolution\$par) cat('"known" inputs were:\n') print(rbind(known)) outs<-list(bbsolution=bbsolution, yfunc=body(yfunc)) return(invisible(outs)) }