R Under development (unstable) (2023-09-30 r85239 ucrt) -- "Unsuffered Consequences"
Copyright (C) 2023 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.

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.

> #-*- R -*-
> 
> ## Script from Fourth Edition of `Modern Applied Statistics with S'
> 
> # Chapter 4   Graphical Output
> 
> library(MASS)
> library(lattice)
> trellis.device(postscript, file="MASS-ch04.ps", width=8, height=6,
+                pointsize=9)
> options(echo=T, width=65, digits=5)
> 
> 
> # 4.2  Basic plotting functions
> 
> topo.loess <- loess(z ~ x * y, topo, degree = 2, span = 0.25)
> topo.mar <- list(x = seq(0, 6.5, 0.2), y=seq(0, 6.5, 0.2))
> topo.lo <- predict(topo.loess, expand.grid(topo.mar))
> topo.lo1 <- cbind(expand.grid(x=topo.mar$x, y=topo.mar$y),
+                   z=as.vector(topo.lo))
> contourplot(z ~ x * y, topo.lo1, aspect = 1,
+   at = seq(700, 1000, 25), xlab = "", ylab = "",
+   panel = function(x, y, subscripts, ...) {
+      panel.levelplot(x, y, subscripts, ...)
+      panel.xyplot(topo$x, topo$y, cex = 0.5)
+   }
+ )
> 
> 
> 
> 
> 
> 
> 
> # 4.5  Trellis graphics
> 
> 
> xyplot(time ~ dist, data = hills,
+   panel = function(x, y, ...) {
+      panel.xyplot(x, y, ...)
+      panel.lmline(x, y, type = "l")
+      panel.abline(lqs(y ~ x), lty = 3)
+ #     identify(x, y, row.names(hills))
+   }
+ )
> 
> bwplot(Expt ~ Speed, data = michelson, ylab = "Experiment No.",
+        main = "Speed of Light Data")
> 
> 
> data(swiss)
> splom(~ swiss, aspect = "fill",
+   panel = function(x, y, ...) {
+      panel.xyplot(x, y, ...); panel.loess(x, y, ...)
+   }
+ )
> 
> sps <- trellis.par.get("superpose.symbol")
> sps$pch <- 1:7
> trellis.par.set("superpose.symbol", sps)
> xyplot(Time ~ Viscosity, data = stormer, groups = Wt,
+    panel = panel.superpose, type = "b",
+    key = list(columns = 3,
+        text = list(paste(c("Weight:   ", "", ""),
+                          unique(stormer$Wt), "gms")),
+        points = Rows(sps, 1:3)
+        )
+ )
> rm(sps)
> 
> topo.plt <- expand.grid(topo.mar)
> topo.plt$pred <- as.vector(predict(topo.loess, topo.plt))
> levelplot(pred ~ x * y, topo.plt, aspect = 1,
+   at = seq(690, 960, 10), xlab = "", ylab = "",
+   panel = function(x, y, subscripts, ...) {
+      panel.levelplot(x, y, subscripts, ...)
+      panel.xyplot(topo$x,topo$y, cex = 0.5, col = 1)
+   }
+ )
> 
> ## if (F) {
> wireframe(pred ~ x * y, topo.plt, aspect = c(1, 0.5),
+   drape = T, screen = list(z = -150, x = -60),
+   colorkey = list(space="right", height=0.6))
> ## }
> 
> lcrabs.pc <- predict(princomp(log(crabs[,4:8])))
> crabs.grp <- c("B", "b", "O", "o")[rep(1:4, each = 50)]
> splom(~ lcrabs.pc[, 1:3], groups = crabs.grp,
+    panel = panel.superpose,
+    key = list(text = list(c("Blue male", "Blue female",
+                             "Orange Male", "Orange female")),
+        points = Rows(trellis.par.get("superpose.symbol"), 1:4),
+        columns = 4)
+   )
> 
> sex <- crabs$sex
> levels(sex) <- c("Female", "Male")
> sp <- crabs$sp
> levels(sp) <- c("Blue", "Orange")
> splom(~ lcrabs.pc[, 1:3] | sp*sex, cex = 0.5, pscales = 0)
> 
> Quine <- quine
> levels(Quine$Eth) <- c("Aboriginal", "Non-aboriginal")
> levels(Quine$Sex) <- c("Female", "Male")
> levels(Quine$Age) <- c("primary", "first form",
+                       "second form", "third form")
> levels(Quine$Lrn) <- c("Average learner", "Slow learner")
> bwplot(Age ~ Days | Sex*Lrn*Eth, data = Quine)
> 
> bwplot(Age ~ Days | Sex*Lrn*Eth, data = Quine, layout = c(4, 2),
+       strip = function(...) strip.default(..., style = 1))
> 
> stripplot(Age ~ Days | Sex*Lrn*Eth, data = Quine,
+          jitter = TRUE, layout = c(4, 2))
> 
> stripplot(Age ~ Days | Eth*Sex, data = Quine,
+    groups = Lrn, jitter = TRUE,
+    panel = function(x, y, subscripts, jitter.data = F, ...) {
+        if(jitter.data)  y <- jitter(as.numeric(y))
+        panel.superpose(x, y, subscripts, ...)
+    },
+    xlab = "Days of absence",
+    between = list(y = 1), par.strip.text = list(cex = 0.7),
+    key = list(columns = 2, text = list(levels(Quine$Lrn)),
+        points = Rows(trellis.par.get("superpose.symbol"), 1:2)
+        ),
+    strip = function(...)
+         strip.default(..., strip.names = c(TRUE, TRUE), style = 1)
+ )
> 
> fgl0 <- fgl[ ,-10] # omit type.
> fgl.df <- data.frame(type = rep(fgl$type, 9),
+   y = as.vector(as.matrix(fgl0)),
+   meas = factor(rep(1:9, each = 214), labels = names(fgl0)))
> stripplot(type ~ y | meas, data = fgl.df,
+   scales = list(x = "free"), xlab = "", cex = 0.5,
+   strip = function(...) strip.default(style = 1, ...))
> 
> if(F) { # no data supplied
+ xyplot(ratio ~ scant | subject, data = A5,
+       xlab = "scan interval (years)",
+       ylab = "ventricle/brain volume normalized to 1 at start",
+       subscripts = TRUE, ID = A5$ID,
+       strip = function(factor, ...)
+          strip.default(..., factor.levels = labs, style = 1),
+       layout = c(8, 5, 1),
+       skip = c(rep(FALSE, 37), rep(TRUE, 1), rep(FALSE, 1)),
+       panel = function(x, y, subscripts, ID) {
+           panel.xyplot(x, y, type = "b", cex = 0.5)
+           which <- unique(ID[subscripts])
+           panel.xyplot(c(0, 1.5), pr3[names(pr3) == which],
+                        type = "l", lty = 3)
+           if(which == 303 || which == 341) points(1.4, 1.3)
+       })
+ }
> 
> Cath <- equal.count(swiss$Catholic, number = 6, overlap = 0.25)
> xyplot(Fertility ~ Education | Cath, data = swiss,
+   span = 1, layout = c(6, 1), aspect = 1,
+   panel = function(x, y, span) {
+      panel.xyplot(x, y); panel.loess(x, y, span)
+   }
+ )
> 
> Cath2 <- equal.count(swiss$Catholic, number = 2, overlap = 0)
> Agr <- equal.count(swiss$Agric, number = 3, overlap = 0.25)
> xyplot(Fertility ~ Education | Agr * Cath2, data = swiss,
+   span = 1, aspect = "xy",
+   panel = function(x, y, span) {
+      panel.xyplot(x, y); panel.loess(x, y, span)
+   }
+ )
> 
> Cath

Data:
 [1]   9.96  84.84  93.40  33.77   5.16  90.57  92.85  97.16
 [9]  97.67  91.38  98.61   8.52   2.27   4.43   2.82  24.20
[17]   3.30  12.11   2.15   2.84   5.23   4.52  15.14   4.20
[25]   2.40   5.23   2.56   7.72  18.46   6.10  99.71  99.68
[33] 100.00  98.96  98.22  99.06  99.46  96.83   5.62  13.79
[41]  11.22  16.92   4.97   8.65  42.34  50.43  58.33

Intervals:
    min    max count
1  2.14   4.53    10
2  4.19   7.73    10
3  6.09  16.93    10
4 13.78  84.85    10
5 58.32  98.23    10
6 97.15 100.01    10

Overlap between adjacent intervals:
[1] 3 2 3 2 3
> levels(Cath)
      [,1]   [,2]
[1,]  2.14   4.53
[2,]  4.19   7.73
[3,]  6.09  16.93
[4,] 13.78  84.85
[5,] 58.32  98.23
[6,] 97.15 100.01
> plot(Cath, aspect = 0.3)
> 
> # End of ch04
> 
> proc.time()
   user  system elapsed 
   1.54    0.03    1.57