Estimating logsitic parameters and random effects with nlme - r

Question

I have managed to fit logistic curves to fit growth models for 129 fish belonging to 3 groups. Unfortunately the parameters I got were not consistent and very often the models I tried have crashed. Therefore I've simulated a data set on which I've tried to fit these parameters and to add a random effect to handle the individual vaiability. I must have missed something with nlme as I was either able to get consistent coefficients or consitent variance estimation but not the two.
set.seed(100)
# coefficients for each group
cf <- structure(c(58.8007098743483, 68.9526514961022, 75.7517805503469,
68.2111807884739, 79.0803042994813, 75.2743397284317, 29.8661527230426,
32.7502759832602, 30.7439702116961), .Dim = c(3L, 3L), .Dimnames = list(
c("gr1", "gr2", "gr3"), c("Asym_mean", "xmid_mean", "scal_mean"
)))
# one curve for each individual
nl <- c(68, 38, 23)
Time <- 1:130
tab <- expand.grid(Individual = 1:sum(nl), Time = Time)
tab <- tab[do.call(order, tab),]
tab$Li <- numeric(nrow(tab))
tab$group <- factor(rep(c("gr1", "gr2", "gr3"), nl*130))
for (i in 1:sum(nl)) {
auxi <- tab$Individu %in% i
sec <- unique(tab$group[auxi])
Asym1 <- rnorm(1, cf[sec, "Asym_mean"], 13)
xmid1 <- rnorm(1, cf[sec, "xmid_mean"], 15)
scal1 <- rnorm(1, cf[sec, "scal_mean"], 4.6)
crois <- sort(SSlogis(Time, Asym1, xmid1, scal1) + rnorm(130, 0, 0.3))
tab$Li[auxi] <- crois
}
tab$Individual <- factor(tab$Individual)
Once I got this data set I tried the following model :
# Initialising coefficients
cfs <- coef(nlsList(Li ~ SSlogis(Time, Asym, xmid, scal)|Individual, data = tab))
cfs <- aggregate(. ~ fac, cbind(cfs, fac = rep(levels(tab$group), nl)), mean)
debt <- lapply(cfs[-1], function(x) c(x[1], x[-1]-x[1]))
debt <- unlist(debt)
# control arguments
lmc <- lmeControl(1e3, 1e3, niterEM=200, msMaxEval = 1e3)
# logistic model for each group
nlme(Li ~ Asym/(1+exp((xmid-Time)/scal)), data = tab,
fixed = Asym + xmid + scal ~ group,
random = Asym + xmid + scal ~ 1|Individual ,
start = debt,
control = lmc)
And I got the following message : "Error in nlme.formula(Li ~ Asym/(1 + exp((xmid - Time)/scal)), data = tab, :
step halving factor reduced below minimum in PNLS step"
I have tried many different formulas and I was not able to get coefficients and random effects estimations.
Regards,
Maxime

Answer 1

Well I didin't find a satisfying answer to this issue. I've tried ADMB, but I've encountered different issues, either I was not able to code this model or I was not able to compile the .ptl file.
I finally used jags to dot it, with the library R2jags.
I hope it could be useful for someone else :
# the code of the bayesian model stored in the file "growth.txt"
model {
for (i in 1:K) {
for (j in 1:n) {
Y[j, i] ~ dnorm(eta[j, i], tauC)
eta[j, i] <- phi1[i] / (1 + exp(-(x[j]-phi2[i])/phi3[i]))
}
## random effect of iˆth tree
phi1[i] <- mu1 + a2*gr2[i] + a3*gr3[i] + a[i]
a[i] ~ dnorm(0, tau1)
phi2[i] <- mu2 + b2*gr2[i] + b3*gr3[i] + b[i]
b[i] ~ dnorm(0, tau2)
phi3[i] <- mu3 + c2*gr2[i] + c3*gr3[i] + c[i]
c[i] ~ dnorm(0, tau3)
}
## priors
tauC ~ dgamma(1.0E-3, 1.0E-3)
logSigma <- -0.5*log(tauC)
logSigmaA <- -0.5*log(tau1)
logSigmaB <- -0.5*log(tau2)
logSigmaC <- -0.5*log(tau3)
mu1 ~ dnorm(0, 1.0E-4)
mu2 ~ dnorm(0, 1.0E-4)
mu3 ~ dnorm(0, 1.0E-4)
a2 ~ dnorm(0, 1.0E-4)
a3 ~ dnorm(0, 1.0E-4)
c2 ~ dnorm(0, 1.0E-4)
c3 ~ dnorm(0, 1.0E-4)
b2 ~ dnorm(0, 1.0E-4)
b3 ~ dnorm(0, 1.0E-4)
c2 ~ dnorm(0, 1.0E-4)
c3 ~ dnorm(0, 1.0E-4)
tau1 ~ dgamma(1.0E-3, 1.0E-3)
tau2 ~ dgamma(1.0E-3, 1.0E-3)
tau3 ~ dgamma(1.0E-3, 1.0E-3)
}
And the associated R lines :
#
library(tidyr)
tabw <- spread(tab[-4], Individual, Li,-2, drop = TRUE)
x <- tabw[,1] # Time
# each Individual belong to one of the three groups
grs <- unique(tab[c(1,4)])
grs <- grs$group[match(colnames(tabw)[-1], grs$Individual)]
# dummy variable
gr2 <- (grs %in% "gr2")*1
gr3 <- (grs %in% "gr3")*1
BUGSData<-list(n = length(x), K = ncol(tabw)-1, x = tabw[,1], Y = tabw[,-1], gr2 = gr2, gr3 = gr3)
cfs <- coef(nlsList(Li ~ SSlogis(Time, Asym, xmid, scal)|Individual, data = tab))
cfs <- cbind(cfs, gr = grs) %>% group_by(gr) %>% summarise_all(funs(mean, sd))
cfs <- cfs %>% mutate(Asym_mean = Asym_mean-Asym_mean[1]*0^((1:n())==1),
xmid_mean = xmid_mean-xmid_mean[1]*0^((1:n())==1),
scal_mean = scal_mean-scal_mean[1]*0^((1:n())==1))
debt <- c(unlist(cfs[2:4]), cfs %>% select(ends_with("sd")) %>% colMeans())
names(debt) <- c("mu1", "a2", "a3", "mu2", "b2", "b3", "mu3", "c2", "c3", "tau1", "tau2", "tau3")
debt <- as.list(debt)
set.seed(1001) ## set RNG seed for R
inits<-c(debt, tauC = 0.1,
.RNG.name="base::Wichmann-Hill", ## set RNG seed/type for JAGS
.RNG.seed=round(runif(1)*1000000))
tfit_jags <- jags(model="growth.txt",
data=BUGSData,
parameters.to.save= c(names(debt),
"logSigma", "logSigmaA", "logSigmaB", "logSigmaC",
"phi1", "phi2", "phi3"),
n.chains=1,
inits=list(inits),
progress.bar="none",
n.iter = 2e3, # 1e6
n.burnin = 1e3 # 1e5,
) # n.thin = 1e3

Answer 2

Finally, I dit it also with ADMB and the library R2 admb with the following code.
This code was freely adapted from the Orange example that can be found here :
https://github.com/admb-project/admb-examples/tree/master/growth-models/orange-trees
The code for growth6.tpl file :
DATA_SECTION
init_int n // Number of data points
init_vector y(1,n) // Response vector
init_vector t(1,n) // Primary covariate
init_int M // Number of groups
init_vector ngroup(1,M) // Group indicator
init_int m // Number of parameters in nonlinear regression model
init_vector gr2(1,M) // dummy variable for being in group 2
init_vector gr3(1,M) // dummy variable for being in group 3
PARAMETER_SECTION
init_bounded_vector beta(1,3,-40,40,1) // Fixed effects parameters
init_bounded_number log_sigma(-5,5.0,1) // log(residual variance)
init_bounded_number log_sigma_u(-10,5,2) // 0.5*log(variance component)
init_bounded_number log_sigma_v(-10,5,3) // 0.5*log(variance component)
init_bounded_number log_sigma_w(-10,5,4) // 0.5*log(variance component)
init_bounded_vector beta2(1,3,-40,40,1) // Fixed effects for group 2
init_bounded_vector beta3(1,3,-40,40,1) // Fixed effects for group 3
random_effects_vector u(1,M,2) // Unscaled random effects
random_effects_vector v(1,M,3)
random_effects_vector w(1,M,3)
objective_function_value g
PRELIMINARY_CALCS_SECTION
cout << setprecision(4); //
GLOBALS_SECTION
#include <df1b2fun.h>
//#include <fvar.hpp>
PROCEDURE_SECTION
int i,ii,iii;
g = 0.0;
ii = 0;
iii = 0;
for(i=1;i<=(int) M;i++) // loop on individuals
{
fit_individual_tree(beta(1),beta(2),beta(3),beta2(1),beta2(2),beta2(3),beta3(1),beta3(2),beta3(3),u(i),v(i),w(i),i,ii,iii,log_sigma,log_sigma_u,log_sigma_v,log_sigma_w);
}
SEPARABLE_FUNCTION void fit_individual_tree(const dvariable& beta1,const dvariable& beta2,const dvariable& beta3,const dvariable& a1,const dvariable& a2,const dvariable& a3,const dvariable& b1,const dvariable& b2,const dvariable& b3,const dvariable& u1,const dvariable& v1,const dvariable& w1,int i,int& ii,int& iii,const dvariable& log_sigma,const dvariable& log_sigma_u,const dvariable& log_sigma_v,const dvariable& log_sigma_w)
int j;
int g1;
int g2;
int g3;
iii++;
dvar_vector a(1,3); // Basic model function parameters
g2 = gr2(iii);
g3 = gr3(iii);
g1 = 1-g2-g3;
a(1) = 62.26 + beta1*g1 + a1*g2 + b1*g3 + u1;
a(2) = 72.90 + beta2*g1 + a2*g2 + b2*g3 + v1;
a(3) = 31.35 + beta3*g1 + a3*g2 + b3*g3 + w1;
dvariable tmp, f;
dvariable sigma = mfexp(log_sigma);
// Random effects contribution
g -= -(log_sigma_u);
g -= -.5*(square(u1/mfexp(log_sigma_u)));
g -= -(log_sigma_v);
g -= -.5*(square(v1/mfexp(log_sigma_v)));
g -= -(log_sigma_w);
g -= -.5*(square(w1/mfexp(log_sigma_w)));
for(j=1;j<=ngroup(i);j++)
{
g -= -log_sigma;
ii++;
f = a(1)/(1+mfexp(-(t(ii)-a(2))/a(3)));
tmp = y(ii) - f;
tmp /= sigma;
g -= -0.5*tmp*tmp;
}
REPORT_SECTION
//report << beta0+beta << endl;
report << exp(log_sigma) << endl;
report << exp(log_sigma_u) << endl;
TOP_OF_MAIN_SECTION
arrmblsize = 40000000L;
gradient_structure::set_GRADSTACK_BUFFER_SIZE(300000000);
gradient_structure::set_CMPDIF_BUFFER_SIZE(20000000);
gradient_structure::set_MAX_NVAR_OFFSET(1000000);
Then the R code to estimate parameters :
library(dplyr)
library(tidyr)
library(nlme)
library(R2admb)
set.seed(100)
# coefficients for each group
# coefficients for each group
cf <- structure(c(58.8007098743483, 68.9526514961022, 75.7517805503469,
68.2111807884739, 79.0803042994813, 75.2743397284317, 29.8661527230426,
32.7502759832602, 30.7439702116961), .Dim = c(3L, 3L), .Dimnames = list(
c("gr1", "gr2", "gr3"), c("Asym_mean", "xmid_mean", "scal_mean"
)))
nl <- c(68, 38, 23)
Time <- 1:130
tab <- expand.grid(Individual = 1:sum(nl), Time = Time)
tab <- tab[do.call(order, tab),]
tab$Li <- numeric(nrow(tab))
tab$group <- factor(rep(c("gr1", "gr2", "gr3"), nl*130))
for (i in 1:sum(nl)) {
auxi <- tab$Individu %in% i
sec <- unique(tab$group[auxi])
Asym1 <- rnorm(1, cf[sec, "Asym_mean"], 13)
xmid1 <- rnorm(1, cf[sec, "xmid_mean"], 15)
scal1 <- rnorm(1, cf[sec, "scal_mean"], 4.6)
crois <- sort(SSlogis(Time, Asym1, xmid1, scal1) + rnorm(130, 0, 0.3))
tab$Li[auxi] <- crois
}
tab$Individual <- factor(tab$Individual)
grs <- unique(tab[c("Individual", "group")])
gr2 <- as.integer((grs$group == "gr2")*1)
gr3 <- as.integer((grs$group == "gr3")*1)
do_admb("growth6",
data =
list(n = nrow(tab), y = tab$Li, t = tab$Time, M = 129, ngroup = rep(130, 129), m=3,
gr2 = gr2, gr3 = gr3),
params =
list(beta = rep(0, 3),
log_sigma = 1, log_sigma_u = 1, log_sigma_v = 1, log_sigma_w = 1,
beta2 = rep(0, 3), beta3 = rep(0, 3),
u = rep(0, 129), v = rep(0, 129), w = rep(0, 129)),
run.opts = run.control(clean_files = "none")
)
ted <- read_admb("growth6")
cfe <- matrix(coef(ted)[grep("beta", names(coef(ted)))]+c(62.26, 72.90, 31.35), 3)
rownames(cfe) <- sprintf("phi%d", 1:3)
colnames(cfe) <- sprintf("gr%d", 1:3)
# we can compare with
coef(nlsList(Li ~ SSlogis(Time, phi1, phi2, phi3)|group, tab))
I hope this could help someone-else.
Max