Initialisation

### Load packages
library(nlme)
library(lattice)
### Load data
load("gd.RData")
## data is contained in a groupedData object 'gd' containing the variables
## - subject (factor)
## - dose    (numeric, µg glycidol per day and kg bw)
## - day     (numeric)
## - value   (numeric, pmol per g hemoglobin)
plot(gd)

Fitting procedure

Define (non-linear) model function

The experimental condition of 28 days dosing, then wash-out, is hard-wired. This function is equivalent to the one defined in Fennell 1992.

f <- function(t, k, tau, bg, D=1){
    ## t: time [d],
    ## k: increase of adduct level per dose [(pmol 2,3-diHOPr-Val/g Hb) / (µg / kg bw)]
    ## tau: erythrocyte life span [1/d]
    ## bg: background (from normal diet) [pmol 2,3-diHOPr-Val/g Hb]
    ## D: dose [µg / kg bw]
    t_end <- 28
    K  <- k / tau
    t_A <- t * (t <= t_end) + t_end * (t > t_end)
    t_B <- (t - tau) * (t > tau  & t <= tau + t_end) +
        t_end * (t > tau + t_end)
    t_C <- (t - t_end) * (t > t_end & t <= tau) +
        (tau - t_end) * (t > tau)
    hb <- (t_A * tau - (t_A**2 / 2) - t_B * t_end + (t_B**2 / 2) - t_C * t_end) * K
    return(D*hb+bg)
}

plot(0:175, f(0:175, k=0.1, tau=120, bg=1, D=2), type="l",
     xlab="day", ylab="adduct level") # View general shape

Simple nls Fit

Start with a simple nls fit. This is not really adequate as all the information on different subjects is disregarded, but gives some idea of the general fit.

fm1.nls <- nls(value~f(day, k, tau, bg, dose),
               data=gd,
               start=list(k=0.1, tau=120, bg=1))
summary(fm1.nls)
## 
## Formula: value ~ f(day, k, tau, bg, dose)
## 
## Parameters:
##      Estimate Std. Error t value Pr(>|t|)    
## k   7.954e-02  1.946e-03   40.88   <2e-16 ***
## tau 1.023e+02  2.760e+00   37.07   <2e-16 ***
## bg  4.154e+00  1.159e-01   35.85   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 1.087 on 239 degrees of freedom
## 
## Number of iterations to convergence: 4 
## Achieved convergence tolerance: 1.552e-06

Some diagnostics The first plot shows that inter-individual differences matter.

plot(fm1.nls, subject~resid(.), abline=0)

plot(fm1.nls)

nlsList Fit

Now fit each subject individually.

fm1.lis <- nlsList(value~f(day, k, tau, bg, dose), data=gd, start=list(k=0.1, tau=120, bg=1))
summary(fm1.lis)
## Call:
##   Model: value ~ f(day, k, tau, bg, dose) | subject 
##    Data: gd 
## 
## Coefficients:
##    k 
##     Estimate  Std. Error  t value     Pr(>|t|)
## A 0.07148671 0.003668779 19.48515 4.819818e-16
## B 0.08261471 0.005793471 14.25997 1.275584e-14
## C 0.07829662 0.003518541 22.25258 6.186026e-16
## D 0.09997922 0.004046353 24.70847 9.275297e-17
## E 0.09727027 0.003979965 24.43998 3.487554e-16
## F 0.10008985 0.003542189 28.25650 2.683363e-16
## G 0.07254100 0.003044713 23.82523 3.342744e-16
## H 0.05963864 0.003035703 19.64574 1.333580e-14
## I 0.07718293 0.003470598 22.23909 2.617216e-11
## J 0.08214518 0.004185801 19.62472 5.566735e-19
## K 0.08906348 0.004232115 21.04467 7.138457e-13
##    tau 
##    Estimate Std. Error  t value     Pr(>|t|)
## A 103.85303   5.776097 17.97979 2.120938e-15
## B 116.11091   8.504968 13.65213 2.821283e-14
## C 137.39787   5.924377 23.19195 2.881314e-16
## D 105.02543   4.561708 23.02327 3.432524e-16
## E 105.12120   4.616265 22.77192 1.285407e-15
## F  92.93440   3.588512 25.89776 1.341081e-15
## G  97.65219   4.556418 21.43179 2.353694e-15
## H  99.01361   5.596642 17.69161 8.949694e-14
## I 113.05941   5.220980 21.65482 4.148214e-11
## J 104.06357   5.736913 18.13930 2.429326e-18
## K  72.59656   4.033514 17.99834 1.132960e-11
##    bg 
##   Estimate Std. Error  t value     Pr(>|t|)
## A 3.522776  0.2216558 15.89300 2.028545e-14
## B 3.724021  0.2456328 15.16093 4.157982e-15
## C 3.135471  0.2620737 11.96408 4.289459e-11
## D 3.534098  0.2223446 15.89469 2.973462e-13
## E 3.884945  0.2225882 17.45351 1.642590e-13
## F 4.679610  0.2115327 22.12240 2.402033e-14
## G 4.679527  0.2168150 21.58304 2.068307e-15
## H 4.105577  0.2180959 18.82464 2.902968e-14
## I 4.880900  0.2401414 20.32511 1.230241e-10
## J 3.103403  0.2217763 13.99339 3.035568e-16
## K 5.171325  0.1911663 27.05144 7.593504e-15
## 
## Residual standard error: 0.6106234 on 209 degrees of freedom

Some diagnostics

plot(fm1.lis, subject~resid(.), abline=0)

plot(fm1.lis)

plot(intervals(fm1.lis))

nlme Fit

This is the interesting part, the population approach. The parameters are fitted as distributions, where each subject’s parameters as considered a realisation of the respective distribution.

fm1.nlme <- nlme(fm1.lis)                        # k, tau and bg random
fm2.nlme <- update(fm1.nlme, random=k+tau~1)     # k, tau random, bg fixed
fm3.nlme <- update(fm1.nlme, random=bg+tau~1)    # bg, tau random, k fixed
fm4.nlme <- update(fm1.nlme, random=k+bg~1)      # k, bg random, tau fixed

anova(fm1.nlme, fm2.nlme, fm3.nlme, fm4.nlme)
##          Model df      AIC      BIC    logLik   Test  L.Ratio p-value
## fm1.nlme     1 10 547.8347 582.7240 -263.9173                        
## fm2.nlme     2  7 596.9594 621.3820 -291.4797 1 vs 2 55.12475  <.0001
## fm3.nlme     3  7 621.6940 646.1165 -303.8470                        
## fm4.nlme     4  7 577.5897 602.0123 -281.7948

With respect to the AIC, fm1.nlme (with all three of k, tau, bg being random) fits best. The following two diagnostic plots indicate that there is no serious problem concerning the model fit.

fm <- fm1.nlme
plot(fm, id=0.01, adj=-1)

qqnorm(fm)

The predicted time course fits the measured values quite well.

plot(augPred(fm, level=0:1))

Final Model

Model summary of the nlme fit.

summary(fm)
## Nonlinear mixed-effects model fit by maximum likelihood
##   Model: value ~ f(day, k, tau, bg, dose) 
##  Data: gd 
##        AIC     BIC    logLik
##   547.8347 582.724 -263.9173
## 
## Random effects:
##  Formula: list(k ~ 1, tau ~ 1, bg ~ 1)
##  Level: subject
##  Structure: General positive-definite, Log-Cholesky parametrization
##          StdDev      Corr         
## k         0.01187872 k      tau   
## tau      14.07542490 -0.202       
## bg        0.64443910  0.119 -0.671
## Residual  0.61047385              
## 
## Fixed effects: list(k ~ 1, tau ~ 1, bg ~ 1) 
##         Value Std.Error  DF  t-value p-value
## k     0.08241  0.003792 229 21.73355       0
## tau 104.21623  4.561540 229 22.84672       0
## bg    4.04530  0.207047 229 19.53805       0
##  Correlation: 
##     k      tau   
## tau -0.183       
## bg   0.041 -0.647
## 
## Standardized Within-Group Residuals:
##          Min           Q1          Med           Q3          Max 
## -3.307200025 -0.639049493  0.009348479  0.581553031  3.468676629 
## 
## Number of Observations: 242
## Number of Groups: 11
coef(fm)
##            k       tau       bg
## A 0.07137660 105.07922 3.540431
## B 0.08218751 113.38314 3.774097
## C 0.07806989 132.59312 3.240926
## D 0.09728040 104.94922 3.661314
## E 0.09559458 104.77586 3.960014
## F 0.09931063  93.43078 4.672621
## G 0.07381048  98.09072 4.583856
## H 0.06079432 100.74858 4.026952
## I 0.07943229 111.87021 4.737768
## J 0.08020358 105.46324 3.206004
## K 0.08848914  75.99445 5.094354
par(mfrow=c(3,1))
boxplot(coef(fm)$k, horizontal = TRUE, main="k")
boxplot(coef(fm)$tau, horizontal = TRUE, main=expression(tau))
boxplot(coef(fm)$bg, horizontal = TRUE, main="bg")

Inverse Model

The steady-state equation for the above model is \(H=D \cdot\tau\cdot k /2+bg\) Assuming bg=0 means that D includes all glycidol intake. Therefore in steady-state, \(D=a\cdot H\) with \(a=\frac{2}{\tau\cdot k}\). The distribution of \(a\) may be estimated by sampling \(k\) and \(\tau\) from the respective distributions, thus obtaining a sample of realisations of \(a\).

set.seed(2018)
N <- 1e6  # number of replications
m.tau <- fixef(fm)["tau"]   # population mean
m.k <- fixef(fm)["k"]       # population mean
sd.tau <- as.numeric(VarCorr(fm)["tau","StdDev"])   # population sd
sd.k <- as.numeric(VarCorr(fm)["k","StdDev"])       # population sd
# now sample a by sampling k and tau from their respective distributions
a.sample <- 2/( rnorm(N, m.tau, sd.tau) * rnorm(N, m.k, sd.k))
names(a.sample) <- NULL

level <- .95; prob <- (1-level)/2
c.interval <- quantile(a.sample, probs=c(prob, .5, 1-prob))
names(c.interval) <- c("lower", "est.", "upper")

A confidence interval for \(a\) is

round(c.interval, digits=3)
## lower  est. upper 
## 0.164 0.235 0.364