Parameter fitting ODE models with nls.lm using short time series - r

Question

I am currently trying to fit functional responses in laboratory experiments accounting for depletion using the Levenberg-Marquardt routine (nls.lm) in minpack. As an example I have been using the levenberg-marquardt routine (nls.lm) in minpack following the tutorial here (http://www.r-bloggers.com/learning-r-parameter-fitting-for-models-involving-differential-equations/).
In the example he fits the data by first setting up a function rxnrate which I modified shown below:
# rate function
rxnrate=function(t,c,parms){
# rate constant passed through a list called parms
a=parms$a
h=parms$h
# c is the concentration of species
# derivatives are computed below
r=rep(0,length(c))
r[1]=-c["B"]*a*c["A"]/(c["B"]+a*h*c["A"])#prey
r[2]=0#predator
# the computed derivatives are returned as a list
# order of derivatives needs to be the same as the order of species in c
return(list(r))
}
My problem is that rather than having a long time series to work with I have many short time series (n=6) with multiple start points. Fitting these individually with the nls.lm function would result in fairly useless estimates. My low-tech solution, which has yielded comparable results to the rogers analytic method, was to arrange them all and fit them simultaneously as in the example below.
# rate function
rxnrate=function(t,c,parms){
# rate constant passed through a list called parms
a=parms$a
h=parms$h
# c is the concentration of species
# derivatives are computed below
r=rep(0,length(c))
r[1]=-c["B"]*a*c["A"]/(c["B"]+a*h*c["A"])#prey
r[2]=0#predator
r[3]=-c["D"]*a*c["C"]/(c["D"]+a*h*c["C"])#prey2
r[4]=0#predator2
r[5]=-c["F"]*a*c["E"]/(c["F"]+a*h*c["E"])#prey3
r[6]=0#predator3
# and so on
return(list(r))
}
The problem with this is that I quickly run out of letters in addition to the fact that it is extremely inefficient to hard code all of these time series (over 100 in total).
My question is because the paired equations are all the same, is there a solution where I can write them once and have the function apply it to all the subsequent paired time series. I also wasn't sure if this solution would lead to any mathematical issues down the road with parameter estimation even though it seems to give comparable results to other methods.
here is a small working example
library(reshape2) # library for reshaping data (tall-narrow <-> short-wide)
library(deSolve) # library for solving differential equations
library(minpack.lm) # library for least squares fit using levenberg-marquart algorithm
#load population data
rate= structure(list(time = c(0, 0.5, 1, 1.5, 2, 2.5), a = c(6L, 5L,
3L, 4L, 3L, 3L), b = c(1L, 1L, 1L, 1L, 1L, 1L), c = c(6L, 3L,
3L, 4L, 2L, 3L), d = c(3L, 3L, 3L, 3L, 3L, 3L), e = c(6L, 6L,
4L, 2L, 3L, 3L), f = c(6L, 6L, 6L, 6L, 6L, 6L), g = c(12L, 8L,
8L, 8L, 8L, 7L), h = c(1L, 1L, 1L, 1L, 1L, 1L), i = c(12L, 11L,
7L, 6L, 3L, 4L), j = c(3L, 3L, 3L, 3L, 3L, 3L), k = c(24L, 12L,
11L, 15L, 8L, 7L), l = c(1L, 1L, 1L, 1L, 1L, 1L)), .Names = c("time",
"a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l"), row.names = c(NA,
6L), class = "data.frame")
rxnrate=function(t,c,parms){
# rate constant passed through a list called parms
a=parms$a
h=parms$h
m=parms$m
# derivatives dc/dt are computed below
r=rep(0,length(c))
holling<-c["B"]*a*c["A"]/(c["B"]+a*h*c["A"])
r[1]=-c["B"]*a*c["A"]/(c["B"]^m+a*h*c["A"]) #dN1/dt
r[2]=0
r[3]=-c["D"]*a*c["C"]/(c["D"]^m+a*h*c["C"]) #dN1/dt
r[4]=0
r[5]=-c["F"]*a*c["E"]/(c["F"]^m+a*h*c["E"]) #dN1/dt
r[6]=0
r[7]=-c["H"]*a*c["G"]/(c["H"]^m+a*h*c["G"]) #dN1/dt
r[8]=0
r[9]=-c["J"]*a*c["I"]/(c["J"]^m+a*h*c["I"]) #dN1/dt
r[10]=0
r[11]=-c["L"]*a*c["K"]/(c["L"]^m+a*h*c["K"]) #dN1/dt
r[12]=0
return(list(r))
}
ssq=function(parms){
# inital concentration
cinit=cinit
# time points for which conc is reported
# include the points where data is available
t=c(seq(0,2.5,0.5),rate$time)
t=sort(unique(t))
# parameters from the parameter estimation routin
a=parms[1]
h=parms[2]
m=parms[3]
# solve ODE for a given set of parameters
out=ode(y=cinit,times=t,func=rxnrate,parms=parms)
# Filter data that contains time points where data is available
outdf=data.frame(out)
outdf=outdf[outdf$time %in% rate$time,]
# Evaluate predicted vs experimental residual
preddf=melt(outdf,id.var="time",variable.name="species",value.name="conc")
expdf=melt(rate,id.var="time",variable.name="species",value.name="conc")
ssqres=preddf$conc-expdf$conc
return(ssqres)
}
# parameter fitting using levenberg marquart algorithm
# initial guess for parameters
control=nls.lm.control(maxiter = 1000,ptol=0.000000000000000000000001,ftol=0.0000000000000000000001)
cinit=c(A=6,B=1,C=6,D=3,E=6,F=6,G=12,H=1,I=12,J=3,K=24,L=1)
parms=list(a=1,h=0.1,m=1)
fit=nls.lm(par=parms,fn=ssq,lower=c(rep(0,3)),upper=c(2,0.5,2),control=control)