
R version 2.15.0 (2012-03-30)
Copyright (C) 2012 The R Foundation for Statistical Computing
ISBN 3-900051-07-0
Platform: x86_64-pc-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> ###################################################
> ### code chunk: Chap20.3influence_init
> ###################################################
> 
> options(width = 65, digits = 5, show.signif.stars = FALSE)
> date()
[1] "Fri Mar 08 18:53:27 2013"
> packageVersion("nlmeU")
[1] '0.30.8'
> packageVersion("nlme")
[1] '3.1.103'
> packageVersion("lattice")
[1] '0.20.6'
> 
> sessionInfo()
R version 2.15.0 (2012-03-30)
Platform: x86_64-pc-mingw32/x64 (64-bit)

locale:
[1] LC_COLLATE=C                          
[2] LC_CTYPE=English_United States.1252   
[3] LC_MONETARY=English_United States.1252
[4] LC_NUMERIC=C                          
[5] LC_TIME=English_United States.1252    

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods  
[7] base     
> require(nlme)    
Loading required package: nlme
> require(lattice) 
Loading required package: lattice
> 
> 
> data(armd, package="nlmeU")
> 
> ## Model M16.5 
> lm3.form <-                 # (12.9, 16.17)
+         formula(visual ~ visual0 + time + treat.f) 
> fm16.5  <-                  # R16.13
+ lme(lm3.form,              
+         random = list(subject = pdDiag(~time)),       
+         weights =varPower(form=~time),
+         data = armd)     
> 
> 
> 
> ###################################################
> ### code chunk: R20.6a
> ###################################################
> fm16.5ml <- update(fm16.5, method = "ML") # ML estimation
> formula(fm16.5ml)                         # Recall model formula.
visual ~ visual0 + time + treat.f
> fm16.5ml$call$data                        # Recall data name.
armd
> logLik(fm16.5ml)                          # Log-likelihood value
'log Lik.' -3210.7 (df=8)
> 
> 
> ###################################################
> ### code chunk: R20.6b
> ###################################################
> beta0  <- fixef(fm16.5ml)                 # beta
> names(beta0)                              # Long names
[1] "(Intercept)"   "visual0"       "time"         
[4] "treat.fActive"
> names(beta0) <- abbreviate(names(beta0), minlength = 7) # Short names 
> beta0                                     # beta printed.
 (Intrc)  visual0     time  trt.fAc 
 5.44721  0.89973 -0.24155 -2.65638 
> vcovb  <- vcov(fm16.5ml)                  # vcovb 
> colnames(vcovb) <- names(beta0)           # Short names
> vcovb                                     # vcovb printed. 
                 (Intrc)     visual0        time     trt.fAc
(Intercept)    5.0475641 -7.9651e-02 -3.8602e-03 -6.8078e-01
visual0       -0.0796512  1.4407e-03  1.5213e-06  1.1239e-03
time          -0.0038602  1.5213e-06  5.6988e-04 -6.1566e-05
treat.fActive -0.6807838  1.1239e-03 -6.1566e-05  1.2568e+00
> 
> 
> ###################################################
> ### code chunk: R20.7a
> ###################################################
> require(nlmeU)  
Loading required package: nlmeU
> df1 <- subset(armd, subject %in% "1")          # Data for subject "1" 
> logLik1(fm16.5ml, df1)                         # logLik_i for subject "1" 
[1] -6.6576
> 
> lLik.i <- by(armd, armd$subject,
+    FUN = function(dfi) logLik1(fm16.5ml, dfi))
> lLik.i <- as.vector(lLik.i)   # Coerse array to vector  
> lLik.i[1:5]                   # logLik_i for the first five subjects
[1]  -6.6576 -13.4708 -11.1361 -13.3109 -12.9930
> sum(lLik.i)                   # Sum logLik_i; compare to Panel 20.6a
[1] -3210.7
> 
> 
> ###################################################
> ### code chunk: R20.7b
> ###################################################
> nx <- by(armd, armd$subject, nrow)             # ni
> lLik.n <- lLik.i/as.vector(nx)                 # logLiki
> outL <- lLik.n < -6                            # TRUE for values < -6
> lLik.n[outL]                                   # logLiki/ni <  -6
[1] -6.0775 -7.2559 -6.2956 -6.9220 -6.3644 -6.7953 -6.5079
> subject.c <- levels(armd$subject)
> subject.x <- as.numeric(subject.c)
> 
> plot(lLik.n ~ subject.x, type = "h")           # Fig. 20.1
> points(subject.x[outL], lLik.n[outL], type = "p", pch = 16)
> text(subject.x[outL], lLik.n[outL], subject.c[outL])
> 
> 
> ###################################################
> ### code chunk: R20.8a
> ###################################################
> lmeU <- function(cx) { 
+     dfU <- subset(armd, subject != cx)          # LOO data 
+     update(fm16.5ml, data = dfU)                # LOO fit 
+ }
> 
> lmeUall        <- lapply(subject.c, lmeU)       # List with LOO fits
> names(lmeUall) <- subject.c                     # Names assigned          
> 
> 
> ###################################################
> ### code chunk: R20.8b
> ###################################################
> names(lmeUall)[1:6]                             
[1] "1" "2" "3" "4" "6" "7"
> dataU6 <- lmeUall[["6"]]$data     # LOO data for subject 6
> dim(dataU6)                       # Number of rows is 863
[1] 863   8
> unique(dataU6$subject)[1:6]       # Subject no. 6 omitted
[1] 1 2 3 4 7 8
234 Levels: 1 2 3 4 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ... 240
> 
> 
> ###################################################
> ### code chunk: R20.9a
> ###################################################
> lLik <- function(cx){                  
+     lmeU   <- lmeUall[[cx]]           # LOO fit extracted 
+     lLikU  <- logLik(lmeU, REML = FALSE)  # LOO log-likelihood
+     df.s   <-                         # Data for subject cx...
+        subset(armd, subject == cx)                 
+     lLik.s <- logLik1(lmeU, df.s)       # ...and log-likelihood.
+     return(lLikU + lLik.s)            # "Displaced" log-likelihood...
+ }
> lLikUall <- sapply(subject.c, lLik)     # ...for all subjects.         
> 
> dif.2Lik <- 2*(logLik(fm16.5ml) - lLikUall) # Vector of LDi
> summary(dif.2Lik)
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
0.00285 0.00948 0.01490 0.05280 0.03300 0.82200 
> 
> 
> ###################################################
> ### code chunk: R20.9b
> ###################################################
> names(dif.2Lik) <- subject.c              # Subjects' ids assigned
> outL  <-  dif.2Lik > 0.5                  # Outlying LDi's
> dif.2Lik[outL]
     73      75     104     114     121     227     231 
0.57543 0.56786 0.56269 0.66459 0.82188 0.55467 0.59549 
> library(lattice)
> subject.f <- factor(subject.c, levels = subject.c)
> myPanel <- function(x, y, ...){
+    x1 <- as.numeric(x)
+    panel.xyplot(x1, y, ...)
+    ltext(x1[outL], y[outL], subject.c[outL])  # Label outlying LDi
+ }
> 
> dtp <-                                        # Fig. 20.2
+    dotplot(dif.2Lik ~ subject.f, panel = myPanel, type = "h")           
> lxlims <- length(dtp$x.limits)         
> update(dtp, xlim = rep("", lxlims), grid = "h") 
> 
> 
> 
> ###################################################
> ### code chunk: R20.10a
> ###################################################
> betaUall <- sapply(lmeUall, fixef)          # Matrix with beta(-i)
> vb.inv <- solve(vcovb)                       
> CookDfun <- function(betaU){  
+    dbetaU <- betaU - beta0                  # beta(-i) - beta
+    CookD.value <- t(dbetaU) %*% vb.inv %*% dbetaU 
+ }
> CookD.num <- apply(betaUall, 2, CookDfun)
> (n.fixeff <- length(beta0))                 # Number of fixed effects
[1] 4
> rankX <- n.fixeff                           # Rank of matrix X
> CookD <- CookD.num/rankX                    # Cook's distance Di
> 
> 
> ###################################################
> ### code chunk: R20.10b
> ###################################################
> outD <- CookD > 0.03                        # Outlying Di's
> subject.c[outD]                             # Subjects' ids 
[1] "75"  "114" "145" "227" "231"
> 
> plot(CookD ~ subject.c, 
+      ylab = "Cook's D", type = "h")         # Fig. 20.3
> text(as.numeric(subject.c[outD]),
+      CookD[outD], subject.c[outD])          # Annotation 
> points(subject.c[outD], CookD[outD])
> 
> sessionInfo()
R version 2.15.0 (2012-03-30)
Platform: x86_64-pc-mingw32/x64 (64-bit)

locale:
[1] LC_COLLATE=C                          
[2] LC_CTYPE=English_United States.1252   
[3] LC_MONETARY=English_United States.1252
[4] LC_NUMERIC=C                          
[5] LC_TIME=English_United States.1252    

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods  
[7] base     

other attached packages:
[1] nlmeU_0.30-8   lattice_0.20-6 nlme_3.1-103  

loaded via a namespace (and not attached):
[1] grid_2.15.0  tools_2.15.0
> 
> proc.time()
   user  system elapsed 
  89.13    0.12   89.54 
