tests/test_predict_nlme.R

In nlraa: Nonlinear Regression for Agricultural Applications

## Example
require(ggplot2)
require(nlme)
require(nlraa)

## I do not want to run this on CRAN servers
run.predict.nlme <- Sys.info()[["user"]] == "fernandomiguez" && FALSE

if(run.predict.nlme){
  
  data(Orange)
  
  ## All models should be fitted using Maximum Likelihood
  fm.L <- nlme(circumference ~ SSlogis(age, Asym, xmid, scal), 
               random = pdDiag(Asym + xmid + scal ~ 1), 
               method = "ML", data = Orange)
  fm.G <- nlme(circumference ~ SSgompertz(age, Asym, b2, b3), 
               random = pdDiag(Asym + b2 + b3 ~ 1), 
               method = "ML", data = Orange)
  fm.F <- nlme(circumference ~ SSfpl(age, A, B, xmid, scal), 
               random = pdDiag(A + B + xmid + scal ~ 1), 
               method = "ML", data = Orange)
  fm.B <- nlme(circumference ~ SSbg4rp(age, w.max, lt.e, ldtm, ldtb), 
               random = pdDiag(w.max + lt.e + ldtm + ldtb ~ 1), 
               method = "ML", data = Orange)
  
  ## Print the table with weights
  IC_tab(fm.L, fm.G, fm.F, fm.B)
  
  ## Each model prediction is weighted according to their AIC values
  prd <- predict_nlme(fm.L, fm.G, fm.F, fm.B)
  
  ggplot(data = Orange, aes(x = age, y = circumference)) + 
    geom_point() + 
    geom_line(aes(y = predict(fm.L, level = 0), color = "Logistic")) +
    geom_line(aes(y = predict(fm.G, level = 0), color = "Gompertz")) +
    geom_line(aes(y = predict(fm.F, level = 0), color = "4P-Logistic")) +  
    geom_line(aes(y = predict(fm.B, level = 0), color = "Beta")) +
    geom_line(aes(y = prd, color = "Avg. Model"), size = 1.2)
  
  ## Testing confidence intervals
  prdc <- predict_nlme(fm.L, fm.G, fm.F, fm.B, interval = "conf")
  OrangeA <- cbind(Orange, prdc)
  
  ggplot(data = OrangeA, aes(x = age, y = circumference)) + 
    geom_point() + 
    geom_line(aes(y = predict(fm.L, level = 0), color = "Logistic")) +
    geom_line(aes(y = predict(fm.G, level = 0), color = "Gompertz")) +
    geom_line(aes(y = predict(fm.F, level = 0), color = "4P-Logistic")) +  
    geom_line(aes(y = predict(fm.B, level = 0), color = "Beta")) +
    geom_line(aes(y = prd, color = "Avg. Model"), size = 1.2) + 
    geom_ribbon(aes(ymin = Q2.5, ymax = Q97.5), fill = "purple", alpha = 0.3)
  
  ## Confidence at the level of individual or Tree in this case
  prdc1 <- predict_nlme(fm.L, fm.G, fm.F, fm.B, interval = "conf", plevel = 1, level = 0.9)
  OrangeAC <- cbind(Orange, prdc1)
  
  ggplot(data = OrangeAC, aes(x = age, y = circumference, color = Tree)) + 
    facet_wrap(~ Tree, ncol = 5) + 
    geom_point() + 
    geom_line(aes(y = Estimate), size = 1.2) + 
    geom_ribbon(aes(ymin = Q5, ymax = Q95, color = NULL, fill = Tree), alpha = 0.3) + 
    ggtitle("90% Confidence bands at the level of 'Tree'")
  
  ## Predictions only make sense at the level of individual or Tree in this case
  prdp <- predict_nlme(fm.L, fm.G, fm.F, fm.B, interval = "pred", plevel = 1, level = 0.9)
  OrangeAP <- cbind(Orange, prdp)
  
  ggplot(data = OrangeAP, aes(x = age, y = circumference, color = Tree)) + 
    facet_wrap(~ Tree, ncol = 5) + 
    geom_point() + 
    geom_line(aes(y = Estimate), size = 1.2) + 
    geom_ribbon(aes(ymin = Q5, ymax = Q95, color = NULL, fill = Tree), alpha = 0.3) + 
    ggtitle("90% Prediciton bands at the level of 'Tree'")
  
  ## Testing new-prediction
  prdnp <- predict_nlme(fm.L, interval = "new-prediction", plevel = 1)
  OrangeANP <- cbind(Orange, prdnp)
  
  ## These should really be unlabal
  OrangeANP$lbs <- with(OrangeANP, paste("New", Tree, sep = "_"))
  ggplot(data = OrangeANP, aes(x = age, y = circumference)) + 
    facet_wrap(~ lbs) + 
    geom_line(aes(y = Estimate, group = Tree)) + 
    geom_ribbon(aes(ymin = Q2.5, ymax = Q97.5), alpha = 0.5) + 
    ggtitle("95% Prediction Band for a NEW Tree")
  
  ## Example using Soybean
  data(Soybean)
  
  ## All models should be fitted using Maximum Likelihood
  fms.L <- nlme(weight ~ SSlogis(Time, Asym, xmid, scal), 
                random = pdDiag(Asym + xmid ~ 1), 
                weights = varPower(),
                method = "ML", data = Soybean)
  fms.G <- nlme(weight ~ SSgompertz(Time, Asym, b2, b3), 
                random = pdDiag(Asym + b2 ~ 1), 
                weights = varPower(),
                method = "ML", data = Soybean)
  fms.B <- nlme(weight ~ SSbg4rp(Time, w.max, lt.e, ldtm, ldtb), 
                random = pdDiag(w.max + lt.e ~ 1), 
                weights = varPower(),
                method = "ML", data = Soybean) 
  fms.W <- nlme(weight ~ SSweibull(Time, Asym, Drop, lrc, pwr),
                 random = pdDiag(Asym + lrc ~ 1),
                 weights = varPower(),
                 method = "ML", data = Soybean)
  fms.E <- nlme(weight ~ SSexplin(Time, cm, rm, tb),
                random = pdDiag(cm + rm ~ 1),
                weights = varPower(),
                method = "ML", data = Soybean)
  fms.T <- nlme(weight ~ SStrlin(Time, a, b, xs1, c, xs2, d),
                random = pdDiag(b + xs1 + c + d ~ 1),
                weights = varPower(),
                method = "ML", data = Soybean)
  
  IC_tab(fms.L, fms.G, fms.B, fms.W, fms.E, fms.T)
  
  ## The beta growth function is the best one by far
  ## No need to perform averaging
  prdsc <- predict_nlme(fms.B, interval = "conf", level = 0.9)
  SoybeanAC <- cbind(Soybean, prdsc)
  
  ggplot(data = SoybeanAC, aes(x = Time, y = weight)) + 
    geom_point() + 
    geom_line(aes(y = Estimate), size = 1.2) + 
    geom_ribbon(aes(ymin = Q5, ymax = Q95), fill = "purple", alpha = 0.3) + 
    ggtitle("90% Confidence bands ")

  prdsp <- predict_nlme(fms.B, interval = "pred", level = 0.9, plevel = 1)
  SoybeanAP <- cbind(Soybean, prdsp)
  
  ggplot(data = SoybeanAP, aes(x = Time, y = weight)) + 
    facet_wrap(~ Plot) + 
    geom_point() + 
    geom_line(aes(y = Estimate), size = 1.2) + 
    geom_ribbon(aes(ymin = Q5, ymax = Q95), fill = "purple", alpha = 0.3) + 
    ggtitle("90% Prediction bands for each plot ")
  
  ## Example with ChickWeight
  data(ChickWeight)
  
  fmc.L <- nlme(weight ~ SSlogis(Time, Asym, xmid, scal), 
                random = pdDiag(Asym + xmid ~ 1), 
                method = "ML", data = ChickWeight)
  
  fmc.G <- nlme(weight ~ SSgompertz(Time, Asym, b2, b3), 
                random = pdDiag(Asym + b2 ~ 1), 
                method = "ML", data = ChickWeight)
  
  fmc.F <- nlme(weight ~ SSfpl(Time, A, B, xmid, scal), 
                random = pdDiag(A + B + xmid ~ 1), 
                method = "ML", data = ChickWeight)

  fmc.B <- nlme(weight ~ SSbg4rp(Time, w.max, lt.e, ldtm, ldtb), 
                random = pdDiag(w.max + lt.e ~ 1), 
                method = "ML", data = ChickWeight)
  
  ## FPL FTW  
  IC_tab(fmc.L, fmc.G, fmc.F, fmc.B)

  prdsch <- predict_nlme(fmc.F, interval = "conf", level = 0.90)
  ChickWeightAC <- cbind(ChickWeight, prdsch)  
  
  ggplot(data = ChickWeightAC, aes(x = Time, y = weight)) + 
    geom_point() + 
    geom_line(aes(y = Estimate), size = 1.2) + 
    geom_ribbon(aes(ymin = Q5, ymax = Q95), fill = "purple", alpha = 0.3) + 
    ggtitle("90% Confidence bands")

  prdschp <- predict_nlme(fmc.F, interval = "pred", level = 0.99, plevel = 1)
  ChickWeightAP <- cbind(ChickWeight, prdschp)  
  
  ggplot(data = ChickWeightAP, aes(x = Time, y = weight)) + 
    facet_wrap(~Chick) + 
    geom_point() + 
    geom_line(aes(y = Estimate), size = 1.2) + 
    geom_ribbon(aes(ymin = Q0.5, ymax = Q99.5), fill = "purple", alpha = 0.3) + 
    ggtitle("99% Prediction bands")
  
}