@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/library/splines/html/R.css

@@ -0,0 +1,130 @@
+@media screen {
+    .container {
+	padding-right: 10px;
+	padding-left: 10px;
+	margin-right: auto;
+	margin-left: auto;
+	max-width: 900px;
+    }
+}
+
+.rimage img { /* from knitr - for examples and demos */
+    width: 96%;
+    margin-left: 2%;
+} 	
+
+.katex { font-size: 1.1em; }
+
+code {
+    color: inherit;
+    background: inherit;
+}
+
+body {
+    line-height: 1.4;
+    background: white;
+    color: black;
+}
+
+a:link {
+    background: white;
+    color: blue;
+}
+
+a:visited {
+    background: white;
+    color: rgb(50%, 0%, 50%);
+}
+
+h1 {
+    background: white;
+    color: rgb(55%, 55%, 55%);
+    font-family: monospace;
+    font-size: 1.4em; /* x-large; */
+    text-align: center;
+}
+
+h2 {
+    background: white;
+    color: rgb(40%, 40%, 40%);
+    font-family: monospace;
+    font-size: 1.2em; /* large; */
+    text-align: center;
+}
+
+h3 {
+    background: white;
+    color: rgb(40%, 40%, 40%);
+    font-family: monospace;
+    font-size: 1.2em; /* large; */
+}
+
+h4 {
+    background: white;
+    color: rgb(40%, 40%, 40%);
+    font-family: monospace;
+    font-style: italic;
+    font-size: 1.2em; /* large; */
+}
+
+h5 {
+    background: white;
+    color: rgb(40%, 40%, 40%);
+    font-family: monospace;
+}
+
+h6 {
+    background: white;
+    color: rgb(40%, 40%, 40%);
+    font-family: monospace;
+    font-style: italic;
+}
+
+img.toplogo {
+    width: 4em;
+    vertical-align: middle;
+}
+
+img.arrow {
+    width: 30px;
+    height: 30px;
+    border: 0;
+}
+
+span.acronym {
+    font-size: small;
+}
+
+span.env {
+    font-family: monospace;
+}
+
+span.file {
+    font-family: monospace;
+}
+
+span.option{
+    font-family: monospace;
+}
+
+span.pkg {
+    font-weight: bold;
+}
+
+span.samp{
+    font-family: monospace;
+}
+
+div.vignettes a:hover {
+    background: rgb(85%, 85%, 85%);
+}
+
+tr {
+    vertical-align: top;
+}
+
+span.rlang {
+    font-family: Courier New, Courier;
+    color: #666666;
+}
+

package/dist/vfs/usr/lib/R/library/splines/tests/sparse-tst.R

@@ -0,0 +1,35 @@
+###----------------- sparse / dense   interpSpline() ---------------------------
+
+## This requires recommended package Matrix.
+
+if(!requireNamespace("Matrix", quietly = TRUE)) q()
+
+require("splines")
+
+## from  help(interpSpline) -- ../man/interpSpline.Rd
+ispl <- interpSpline( women$height, women$weight)
+isp. <- interpSpline( women$height, women$weight, sparse=TRUE)
+stopifnot(all.equal(ispl, isp., tol = 1e-12)) # seen 1.65e-14
+
+##' @title Interpolate size-n version of the 'women' data sparsely and densely
+##' @param n size of "women-like" data to interpolate
+##' @return list with dense and sparse \code{\link{system.time}()}s
+##' @author Martin Maechler
+ipStime <- function(n) { # and using 'ispl'
+    h <- seq(55, 75, length.out = n)
+    w <- predict(ispl, h)$y
+    c.d <- system.time(is.d <- interpSpline(h, w, sparse=FALSE))
+    c.s <- system.time(is.s <- interpSpline(h, w, sparse=TRUE ))
+    stopifnot(all.equal(is.d, is.s, tol = 1e-7)) # seen 9.4e-10 (n=1000), 1.3e-7 (n=5000)
+    list(d.time = c.d, s.time = c.s)
+}
+
+n.s <- 25 * round(2^seq(1,6, by=.5))
+if(!interactive())# save 'check time'
+    n.s <- n.s[100 <= n.s & n.s <= 800]
+(ipL <- lapply(setNames(n.s, paste0("n=",n.s)), ipStime))
+## sparse is *an order of magnitude* faster for n ~= 1000 but somewhat slower for n ~< 200:
+sapply(ipL, function(ip) round(ip$d.time / ip$s.time, 1)[c(1,3)])
+##           n=50 n=75 n=100 n=150 n=200 n=275 n=400 n=575 n=800 n=1125 n=1600 -- nb-mm4, i7-5600U
+## user.self  0.5  0.5   0.5   0.5   0.7   2.5   4.3  12.3  33.7   70.5  116.1
+## elapsed    0.5  0.3   0.5   0.7   1.0   2.5   4.3  13.0  26.2   57.4  117.3

package/dist/vfs/usr/lib/R/library/splines/tests/spline-tst.R

@@ -0,0 +1,296 @@
+require("splines")
+
+## Bug report PR#16549 - 'bad value from splineDesign'
+## Date: Wed, 30 Sep 2015 12:12:47 +0000
+## https://bugs.r-project.org/show_bug.cgi?id=16549
+
+## Reporter: roconnor@health.usf.edu  (extended original example code)
+
+kn8.01 <- c(0,0,0,0,1,1,1,1)
+m1  <- rbind(c(1, 0,0,0))
+m.1 <- rbind(c(0,0,0, 1))
+stopifnot(
+    ## the first gave (0 0 0 0) instead of m1 :
+    all.equal(splineDesign(kn8.01, c(0,2),    outer.ok = TRUE), rbind(m1, 0)),
+    all.equal(splineDesign(kn8.01, c( 0,1,2), outer.ok = TRUE), rbind(m1, m.1, 0)),
+    all.equal(splineDesign(kn8.01, c(-1,0,1), outer.ok = TRUE), rbind(0, m1, m.1)),
+    all.equal(splineDesign(kn8.01, 0, outer.ok = TRUE), m1),
+    all.equal(splineDesign(kn8.01, 0), m1),
+    TRUE)
+
+## The original fix proposal introduced a new bug, visible here:
+S <- splineDesign(c(-3, -3, -2, 0, 2, 3, 3), x= -3:3, outer.ok=TRUE)
+## (had a NaN in the lower-right corner)
+stopifnot(all.equal(S,
+		    rbind(0, c(22,3,0)/45, c(193, 6*23, 9)/360,
+			  c(1,3,1)/5,
+			  c(9, 6*23, 193)/360,
+			  c(0,3,22)/45, 0),
+		    tolerance = 1e-14))
+
+chkSum.Ok <- TRUE ## for check
+chkSum <- function(knots, n = 1 + 2^9, ord = 4) {
+    stopifnot(is.numeric(knots), !is.unsorted(knots), (n.k <- length(knots)) >= ord)
+    dk <- diff(rk <- range(uk <- unique(knots)))
+    if(dk == 0) dk <- uk[1]/4
+    d.x <- dk / (2*n.k)
+    ## x: the unique knots
+    x <- sort(c(uk, seq.int(min(knots)-d.x, max(knots)+d.x, length.out = n)))
+    bb <- splineDesign(knots, x = x, ord = ord, outer.ok = TRUE)
+    is.x.in <- knots[ord] <= x & x <= knots[n.k-(ord-1)]
+    ##                   ~~~~     ~~~~  same as in splineDesign(*, outer.ok=TRUE)
+    ##
+### no longer needed:
+    ## work around "infelicity" (or not; not sure if to call "bug")
+    ## n.RHk := #{duplicated RHS boundary knots}
+    ## n.RHk <- match(FALSE, rev(duplicated(knots)))
+    ## if(ord > 1 && n.RHk > ord) { ## the (ord == 1) case "works" via spike = 1
+    ##     ## <==> knots[n.k -j ] == knots[n.k] for j = 0,1,..,(n.RHk-1)
+    ##     ## then spl(x= RHS-knot, knots) == 0, even though "should" be 1
+    ##     ## "FIX it up" for here. FIXME: do in splineDesign() or it's C code ?!
+    ##     iR <- which(x == knots[n.k])
+    ##     ## ncol(bb) == n.k - ord
+    ##     j <- n.k - n.RHk # == ncol(bb) - (n.RHk - ord)
+    ##     if(any(bb[iR, j] == 0)) bb[iR, j] <- 1
+    ## }
+    sumB <- rowSums(bb)
+    if(any(iBad <- !is.finite(sumB))) {
+	chkSum.Ok <<- FALSE ## for check
+	cat("** _FIXME_ NON-finite values in sumB: ord = ", ord, "; |knots| =", n.k,"\n")
+	cat("knots <- "); dput(knots)
+	cat("non-finite at x = "); dput(x[iBad])
+    } else if(length(bb)) { # only when bb[] is not 0-dimensional
+	eps <- 3*.Machine$double.eps
+	stopifnot(abs(1 - sumB[is.x.in]) <= 2*eps, 0 <= sumB+eps, sumB-2*eps <= 1,
+		  allow.logical0=TRUE)
+	## TODO: now also check derivatives
+    }
+    invisible(bb)
+}
+
+plotSplD <- function(knots, n = 2^10, ord = 4, type = "l",
+		     ylim = c(0,1), ylab = "B-splines", ...) {
+    stopifnot(is.numeric(knots), !is.unsorted(knots), (n.k <- length(knots)) >= ord)
+    dk <- diff(range(uk <- unique(knots)))
+    if(dk == 0) dk <- uk[1]/4
+    d.x <- dk / (2*n.k)
+    ## x: will contain the unique knots uk
+    x <- sort(c(uk, seq.int(min(knots)-d.x, max(knots)+d.x, length.out = n)))
+    bb <- splineDesign(knots, x = x, ord = ord, outer.ok = TRUE)
+    matplot(x, bb, type=type, ylim=ylim, ylab=ylab, ...)
+    sumB <- rowSums(bb)
+    abline(v = knots, lty = 3, col = "light gray")
+    abline(v = knots[c(ord, n.k-(ord-1))], lty = 3, col = "gray10")
+    lines(x, sumB, col = adjustcolor("red", 0.4), lwd = 3)
+    abline(h=1, lty=2, col = adjustcolor(1, 0.4), lwd = 2)
+    ## lty, col,: from matplot()
+    legend(mean(x), 0.98, legend = paste0("B_", 1:ncol(bb)), lty=1:5, col=1:6,
+	   bty = "n", xjust = 0.5)
+    invisible(list(x=x, splineDesign = bb))
+}
+
+if(!dev.interactive(orNone=TRUE)) pdf("spline-tst.pdf")
+
+plotSplD(kn8.01)
+chkSum  (kn8.01)
+
+## from ../man/splineDesign.Rd :
+knots <- c(1,1.8,3:5,6.5,7,8.1,9.2,10)  # 10 => 10-4 = 6 Basis splines
+str(plotSplD(knots))       # cubic     splines, adding to 1 in [ 4, 7 ]
+str(plotSplD(knots, ord=3))# quadratic splines, adding to 1 in [ 3, 8.1]
+str(plotSplD(knots, ord=2))# linear    splines, adding to 1 in [1.8,9.2]
+str(plotSplD(knots, ord=1))# constant  splines, adding to 1 in [1, 10]
+
+chkSum(knots)
+chkSum(knots, ord=3)
+chkSum(knots, ord=2)
+chkSum(knots, ord=1)
+
+## cases that failed too {Linux lynne 4.1.6 x86_64}
+chkSum(c(1:5, 9,9),     ord=2) # ok for ord in {1,3,4}
+chkSum(c(1:4, 9,9,9),   ord=3)
+chkSum(c(1:3, 9,9,9,9), ord=4)
+## These failed in R <= 3.2.2 (but not after first fix):
+chkSum(c(0,0,0,0, 1:3), ord=4)
+chkSum(c(0,0,0,   1:4), ord=3)
+chkSum(c(0,0,     1:5), ord=2)
+
+## This should be symmetric, but was not;
+## the graphic is maybe most convincing:
+k6.01 <- c(0,0,0, 1,1,1)
+round(with(plotSplD(k6.01, ord=2, n=16), cbind(x, splineDesign)), 4)
+x8 <- (0:8)/8
+sp8 <- splineDesign(k6.01, x=x8, ord=2)
+print.table(8*sp8, zero.print=".")
+stopifnot(all.equal(8*sp8,
+		    cbind(0, 8:0, 0:8, 0), tol = 1e-14))
+## or just
+splineDesign(k6.01, x=0:1, ord=2)
+##  0 1 0 0
+##  0 0 1 0 --- [finally !]
+stopifnot(identical(cbind(0, diag(2), 0),
+		    splineDesign(k6.01, x=0:1, ord=2)))
+
+## Further:
+for(k in 0:8)
+    chkSum(c(0:k, 9,9,9),     ord=2)
+for(k in 0:8)
+    chkSum(c(0:k, 9,9,9,9),   ord=3)
+for(k in 0:8)
+    chkSum(c(0:k, 9,9,9,9,9), ord=4)
+
+## look at two examples
+r  <- plotSplD(c(0:4, 8.9,9,9,9), ord=3)# B_6 is narrow spike
+r. <- plotSplD(c(0:4,  9, 9,9,9), ord=3)# B_6 diverged to all zero.
+if(interactive())
+    round(with(r., cbind(x, splineDesign)), 4)
+stopifnot(r.$splineDesign[, 6] == 0)
+## one could argue that B_6 should also have finite area, and hence be "a delta".
+## ==> sum_j B_j(x = 9) would then be Inf or undefined ..
+## more sensible: B_6 should be omitted and should have B_5(9) == 1
+## now implemented:
+stopifnot(identical(c(0, 0, 0, 0, 1, 0),
+		    with(r., splineDesign[x == 9,])))
+
+## Everything is fine, if  left-right  mirrored / reversed :
+r03 <- plotSplD(c(0,0,0,0,  1:5), ord=3)
+## here, B_1 is "delta" and should rather be omitted
+stopifnot(identical(c(0, 1, 0, 0, 0, 0),
+		    with(r03, splineDesign[x == 0,])))
+## 0 1 0 0 0 0 -- as it should be ..
+round(with(r03, cbind(x, splineDesign)[50:60,]), 4)
+
+r04 <- plotSplD(c(0,0,0,0,  1:5), ord=4)
+## here, B_1 is "delta" and should rather be omitted
+stopifnot(identical(c(1, 0, 0, 0, 0),
+		    with(r04, splineDesign[x == 0,])))
+round(with(r04, cbind(x, splineDesign)[50:60,]), 4)
+
+r0.4 <- plotSplD(c(0,0,0, 1:5), ord=4) # basis is nice and correct
+
+
+set.seed(17)
+
+for(n in 1:1000) {
+    if(n %% 50 == 0) cat(sprintf("n = %4d\n",n))
+    kn <- sort.int(round(10* rnorm(4 + rpois(1, lambda=4))))
+    for(oo in 1:4)
+	## if(inherits(r <- tryCatch(chkSum(kn, ord=oo), error=identity), "error"))
+	##     cat(r$message, "\n chkSum(", deparse(kn), ", ord = ", oo, ")\n")
+	chkSum(kn, ord = oo)
+}
+
+## One of the cases with NaN {when used  ( . <= x & x <= . )}:
+
+bb <- chkSum(c(-14, -4, 3, 5, 6, 15, 15))
+stopifnot(is.finite(rowSums(bb)))
+
+
+stopifnot(chkSum.Ok)
+
+proc.time()
+
+###---- "Bug report" (to R-core) from Trevor Hastie ---
+###---->  bs(*, Boundary.knots = .)
+### needing boundary ajustment for correct extrapolation
+
+## Trevor's Example, slightly modified and extended:
+x <- seq(1.5, 8.5, by = 1/4)
+set.seed(13)
+y <- x + .01*(x - 5)^3 + rnorm(x)
+
+fit0 <- lm(y ~ bs(x, degree=3, knots=4))
+fit0.<- lm(y ~ bs(x, degree=3, knots=4, Boundary.knots=c(1,9)))# *NOT* outside
+fit1 <- lm(y ~ bs(x, degree=3, knots=4, Boundary.knots=c(1,8)))# warning
+fit2 <- lm(y ~ bs(x, degree=3, knots=4, Boundary.knots=c(2,8)))# warning "2 x"
+
+jx <- seq(from=-2,to=12, by=0.1)
+p0 <- predict(fit0, list(x=jx))
+p0.<- predict(fit0, list(x=jx))
+p1 <- predict(fit1, list(x=jx))
+p2 <- predict(fit2, list(x=jx))
+stopifnot(all.equal(p0, p0.,tol=1e-14),
+          all.equal(p0, p1, tol=1e-14),
+          all.equal(p0, p2, tol=1e-14))
+## ^^  p1 and p2 differed from p0 in R <= 3.2.2
+## See numerical fuzz:
+all.equal(p0, p0., tol=0)
+all.equal(p0, p1,  tol=0)
+all.equal(p0, p2,  tol=0)
+all.equal(p1, p2,  tol=0)# interestingly almost the same
+
+## formula ==> print for default method
+ispl <- with(women, interpSpline( height, weight ))
+stopifnot(identical(format(formula(ispl)),
+		    "weight ~ height")) ## was wrongly .Primitive(\"~\")(wei...
+
+###------------- Problems for small n ------- want at least good error messages ---
+
+## This gives an error, but not a "human readable" one for k <= 3
+## -- now done: the English error message is  "must have at least 'ord'=4 points"
+## FIXME: Would like to get degree=0 (constant), 1, 2 interpolation spline here
+##        (and could use degree = 0 for both n=0 and n=1) ==> would have *no* error here
+for(n in 0:4) {
+    cat("n = ", n,": ")
+    x <- cumsum(pmax(1, round(10*runif(n)))) # pmax(1,*): x[] must be distinct
+    y <- (x - 2)^2 + round(8*rnorm(n))/4
+    if(!inherits(sp <- try(interpSpline(x,y)), "try-error")) print(sp)
+    cat("-------------------------------\n")
+}
+## for n=4:
+stopifnot(inherits(sp, "polySpline"), is.matrix(sp$coefficients),
+          identical(dim(sp$coefficients), c(4L, 4L)))
+
+## This also gives a "hard to read" error _FIXME_
+try(ns(1[0])) # n = 0
+## Error in splineDesign(Aknots, x, ord) :
+##   length of 'derivs' is larger than length of 'x' -- barely ok  + 2 warnings
+try(bs(1[0])) # n = 0 :  same error etc as  ns()
+
+(b1 <- bs(pi)) # n = 1 :  works fine
+(n1 <- ns(pi)) # n = 1 : now ok; gave error:  "qr.default(.. NA ...)"
+
+##' keep {dim, dimnames} but nothing else :
+noAttr <- function(x) `mostattributes<-`(x, list(dim=dim(x), dimnames=dimnames(x)))
+stopifnot(
+    identical(noAttr(b1), rbind(c(`1`=0, `2`=0, `3`=0))),
+    all.equal(noAttr(n1), matrix(0.400891862868637, 1, dimnames=list(NULL,"1")),
+	      tol = 5e-15))
+
+d1 <- data.frame(u = 2, Y = 5) ## data set with 1 observation
+summary(mbs  <- lm(Y ~ bs(u),           data=d1)) # fine though many coef etc are NA
+summary(mbs1 <- lm(Y ~ bs(u, degree=1), data=d1)) # ok
+stopifnot(
+    identical(coef(mbs), setNames(c(5, NA, NA, NA),
+                                  c("(Intercept)", paste0("bs(u)", 1:3))))
+    ,
+    identical(coef(mbs1), c("(Intercept)" = 5, "bs(u, degree = 1)" = NA)))
+if(FALSE)
+summary(mbs0 <- lm(Y ~ bs(u, degree=0), data=d1)) # error: degree >= 1
+
+## ns() has no 'degree' argument!
+summary(mns  <- lm(Y ~ ns(u),       data=d1)) ## gave Error; now ok
+stopifnot(identical(coef(mns),  c("(Intercept)" = 5, "ns(u)" = NA))
+	  ## perfect prediction: all residuals == 0 :
+	, identical(residuals(mns), c(`1` = 0))
+	, identical(residuals(mbs), c(`1` = 0))
+	, identical(residuals(mbs1),c(`1` = 0))
+	  )
+
+
+## [Bug 18442] ns() fails when quantiles end up on the boundary  (2022-12-05)
+##  =========  ---- 1st example ===> <R>/tests/reg-tests-1e.R  'ns(nn,4)'
+##
+## a (more extreme) example where bs() is affected similarly:
+require(splines)
+##
+x <- c(rep(0L, 44), 1:10, 2L*(6:15), as.integer(round(1.25^(15:22))))
+y <- 10L*x + c(-1L,1L)
+B <- bs(x, df = 7)
+summary(m <- lm(y ~ B))
+stopifnot(exprs = {
+    qr(B)$rank == 7
+    all.equal(c(0, 0.03265, 20.53, 21.79, 73.27, 519.8, 964.3, 1361),
+              unname(coef(m)), tol = 1e-4)
+})
+## rank was 5, and coef(m) had 3 NA's in R <= 4.2.x

package/dist/vfs/usr/lib/R/library/stats/demo/glm.vr.R

@@ -0,0 +1,24 @@
+#  Copyright (C) 1997-2009 The R Core Team
+
+#### -*- R -*-
+require(stats)
+Fr <- c(68,42,42,30, 37,52,24,43,
+	66,50,33,23, 47,55,23,47,
+	63,53,29,27, 57,49,19,29)
+
+Temp <- gl(2, 2, 24, labels = c("Low", "High"))
+Soft <- gl(3, 8, 24, labels = c("Hard","Medium","Soft"))
+M.user <- gl(2, 4, 24, labels = c("N", "Y"))
+Brand <- gl(2, 1, 24, labels = c("X", "M"))
+
+detg <- data.frame(Fr,Temp, Soft,M.user, Brand)
+detg.m0 <- glm(Fr ~ M.user*Temp*Soft + Brand, family = poisson, data = detg)
+summary(detg.m0)
+
+detg.mod <- glm(terms(Fr ~ M.user*Temp*Soft + Brand*M.user*Temp,
+                      keep.order = TRUE),
+		family = poisson, data = detg)
+summary(detg.mod)
+summary(detg.mod, correlation = TRUE, symbolic.cor = TRUE)
+
+anova(detg.m0, detg.mod)

package/dist/vfs/usr/lib/R/library/stats/demo/lm.glm.R

@@ -0,0 +1,144 @@
+### Examples from: "An Introduction to Statistical Modelling"
+###			By Annette Dobson
+###
+### == with some additions ==
+
+#  Copyright (C) 1997-2015 The R Core Team
+
+require(stats); require(graphics)
+
+## Plant Weight Data (Page 9)
+ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14)
+trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69)
+group <- gl(2,10, labels=c("Ctl","Trt"))
+weight <- c(ctl,trt)
+anova  (lm(weight~group))
+summary(lm(weight~group -1))
+
+
+## Birth Weight Data (Page 14)
+age <- c(40, 38, 40, 35, 36, 37, 41, 40, 37, 38, 40, 38,
+	 40, 36, 40, 38, 42, 39, 40, 37, 36, 38, 39, 40)
+birthw <- c(2968, 2795, 3163, 2925, 2625, 2847, 3292, 3473, 2628, 3176,
+	    3421, 2975, 3317, 2729, 2935, 2754, 3210, 2817, 3126, 2539,
+	    2412, 2991, 2875, 3231)
+sex <- gl(2,12, labels=c("M","F"))
+plot(age, birthw, col=as.numeric(sex), pch=3*as.numeric(sex),
+     main="Dobson's Birth Weight Data")
+lines(lowess(age[sex=='M'], birthw[sex=='M']), col=1)
+lines(lowess(age[sex=='F'], birthw[sex=='F']), col=2)
+legend("topleft", levels(sex), col=1:2, pch=3*(1:2), lty=1, bty="n")
+
+summary(l1 <- lm(birthw ~ sex + age),    correlation=TRUE)
+summary(l0 <- lm(birthw ~ sex + age -1), correlation=TRUE)
+anova(l1,l0)
+summary(li <- lm(birthw ~ sex + sex:age -1), correlation=TRUE)
+anova(li,l0)
+
+summary(zi <- glm(birthw ~ sex + age, family=gaussian()))
+summary(z0 <- glm(birthw ~ sex + age - 1, family=gaussian()))
+anova(zi, z0)
+
+summary(z.o4 <- update(z0, subset = -4))
+summary(zz <- update(z0, birthw ~ sex+age-1 + sex:age))
+anova(z0,zz)
+
+## Poisson Regression Data (Page 42)
+x <- c(-1,-1,0,0,0,0,1,1,1)
+y <- c(2,3,6,7,8,9,10,12,15)
+summary(glm(y~x, family=poisson(link="identity")))
+
+
+## Calorie Data (Page 45)
+calorie <- data.frame(
+    carb = c(33,40,37,27,30,43,34,48,30,38,
+	     50,51,30,36,41,42,46,24,35,37),
+    age	 = c(33,47,49,35,46,52,62,23,32,42,
+	     31,61,63,40,50,64,56,61,48,28),
+    wgt	 = c(100, 92,135,144,140,101, 95,101, 98,105,
+	     108, 85,130,127,109,107,117,100,118,102),
+    prot = c(14,15,18,12,15,15,14,17,15,14,
+	     17,19,19,20,15,16,18,13,18,14))
+summary(lmcal <- lm(carb~age+wgt+prot, data= calorie))
+
+
+## Extended Plant Data (Page 59)
+ctl <-	c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14)
+trtA <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69)
+trtB <- c(6.31,5.12,5.54,5.50,5.37,5.29,4.92,6.15,5.80,5.26)
+group <- gl(3, length(ctl), labels=c("Ctl","A","B"))
+weight <- c(ctl,trtA,trtB)
+anova(lmwg <- lm(weight~group))
+summary(lmwg)
+coef(lmwg)
+coef(summary(lmwg))#- incl.  std.err,  t- and P- values.
+
+
+## Fictitious Anova Data (Page 64)
+y <- c(6.8,6.6,5.3,6.1,7.5,7.4,7.2,6.5,7.8,9.1,8.8,9.1)
+a <- gl(3,4)
+b <- gl(2,2, length(a))
+anova(z <- lm(y~a*b))
+
+
+## Achievement Scores (Page 70)
+y <- c(6,4,5,3,4,3,6, 8,9,7,9,8,5,7, 6,7,7,7,8,5,7)
+x <- c(3,1,3,1,2,1,4, 4,5,5,4,3,1,2, 3,2,2,3,4,1,4)
+m <- gl(3,7)
+anova(z <- lm(y~x+m))
+
+
+## Beetle Data (Page 78)
+dose <- c(1.6907, 1.7242, 1.7552, 1.7842, 1.8113, 1.8369, 1.861, 1.8839)
+x <- c( 6, 13, 18, 28, 52, 53, 61, 60)
+n <- c(59, 60, 62, 56, 63, 59, 62, 60)
+dead <- cbind(x, n-x)
+summary(     glm(dead ~ dose, family=binomial(link=logit)))
+summary(     glm(dead ~ dose, family=binomial(link=probit)))
+summary(z <- glm(dead ~ dose, family=binomial(link=cloglog)))
+anova(z, update(z, dead ~ dose -1))
+
+
+## Anther Data (Page 84)
+## Note that the proportions below are not exactly
+## in accord with the sample sizes quoted below.
+## In particular, the last value, 5/9, should have been 0.556 instead of 0.555:
+n <- c(102,  99,   108,	 76,   81,   90)
+p <- c(0.539,0.525,0.528,0.724,0.617,0.555)
+x <- round(n*p)
+## x <- n*p
+y <- cbind(x,n-x)
+f <- rep(c(40,150,350),2)
+(g <- gl(2,3))
+summary(glm(y ~ g*f, family=binomial(link="logit")))
+summary(glm(y ~ g + f, family=binomial(link="logit")))
+## The "final model"
+summary(glm.p84 <- glm(y~g,  family=binomial(link="logit")))
+op <- par(mfrow = c(2,2), oma = c(0,0,1,0))
+plot(glm.p84) # well ?
+par(op)
+
+## Tumour Data (Page 92)
+counts <- c(22,2,10,16,54,115,19,33,73,11,17,28)
+type <- gl(4,3,12,labels=c("freckle","superficial","nodular","indeterminate"))
+site <- gl(3,1,12,labels=c("head/neck","trunk","extremities"))
+data.frame(counts,type,site)
+summary(z <- glm(counts ~ type + site, family=poisson()))
+
+## Randomized Controlled Trial (Page 93)
+counts <- c(18,17,15, 20,10,20, 25,13,12)
+outcome   <- gl(3, 1, length(counts))
+treatment <- gl(3, 3)
+summary(z <- glm(counts ~ outcome + treatment, family=poisson()))
+
+## Peptic Ulcers and Blood Groups
+counts <- c(579, 4219, 911, 4578, 246, 3775, 361, 4532, 291, 5261, 396, 6598)
+group <- gl(2, 1, 12, labels=c("cases","controls"))
+blood <- gl(2, 2, 12, labels=c("A","O"))
+city  <- gl(3, 4, 12, labels=c("London","Manchester","Newcastle"))
+cbind(group, blood, city, counts) # gives internal codes for the factors
+
+summary(z1 <- glm(counts ~ group*(city + blood), family=poisson()))
+summary(z2 <- glm(counts ~ group*city + blood, family=poisson()),
+        correlation = TRUE)
+anova(z2, z1, test = "Chisq")