
R version 4.5.1 (2025-06-13 ucrt) -- "Great Square Root"
Copyright (C) 2025 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64

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.

  Natural language support but running in an English locale

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.

[Previously saved workspace restored]

> ###################################################
> ### code chunk: Chap20.3influence_init
> ###################################################
> 
> options(width = 65, digits = 5, show.signif.stars = FALSE)
> date()
[1] "Mon Aug  4 21:00:40 2025"
> packageVersion("nlmeU")
[1] '0.75.0'
> packageVersion("nlme")
[1] '3.1.166'
> packageVersion("lattice")
[1] '0.22.6'
> 
> sessionInfo()
R version 4.5.1 (2025-06-13 ucrt)
Platform: x86_64-w64-mingw32/x64
Running under: Windows 11 x64 (build 22631)

Matrix products: default
  LAPACK version 3.12.1

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

time zone: America/New_York
tzcode source: internal

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

loaded via a namespace (and not attached):
[1] compiler_4.5.1 nlme_3.1-166   grid_4.5.1     lattice_0.22-6
> 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.0475643 -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

Attaching package: 'nlmeU'

The following objects are masked _by_ '.GlobalEnv':

    armd, armd.wide, fcat, prt, prt.subjects, SIIdata

> 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.01488 0.05283 0.03299 0.82188 
> 
> 
> ###################################################
> ### 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 4.5.1 (2025-06-13 ucrt)
Platform: x86_64-w64-mingw32/x64
Running under: Windows 11 x64 (build 22631)

Matrix products: default
  LAPACK version 3.12.1

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

time zone: America/New_York
tzcode source: internal

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

other attached packages:
[1] nlmeU_0.75-0   lattice_0.22-6 nlme_3.1-166  

loaded via a namespace (and not attached):
[1] compiler_4.5.1 tools_4.5.1    grid_4.5.1    
> 
> proc.time()
   user  system elapsed 
  34.78    2.56   51.73 
