
R Under development (unstable) (2022-03-19 r81942) -- "Unsuffered Consequences"
Copyright (C) 2022 The R Foundation for Statistical Computing
Platform: x86_64-pc-linux-gnu (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.

  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.

> pkgname <- "stats"
> source(file.path(R.home("share"), "R", "examples-header.R"))
> options(warn = 1)
> library('stats')
> 
> base::assign(".oldSearch", base::search(), pos = 'CheckExEnv')
> base::assign(".old_wd", base::getwd(), pos = 'CheckExEnv')
> cleanEx()
> nameEx("AIC")
> ### * AIC
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: AIC
> ### Title: Akaike's An Information Criterion
> ### Aliases: AIC BIC
> ### Keywords: models
> 
> ### ** Examples
> 
> lm1 <- lm(Fertility ~ . , data = swiss)
> AIC(lm1)
[1] 326.0716
> stopifnot(all.equal(AIC(lm1),
+                     AIC(logLik(lm1))))
> BIC(lm1)
[1] 339.0226
> 
> lm2 <- update(lm1, . ~ . -Examination)
> AIC(lm1, lm2)
    df      AIC
lm1  7 326.0716
lm2  6 325.2408
> BIC(lm1, lm2)
    df      BIC
lm1  7 339.0226
lm2  6 336.3417
> 
> 
> 
> cleanEx()
> nameEx("ARMAacf")
> ### * ARMAacf
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ARMAacf
> ### Title: Compute Theoretical ACF for an ARMA Process
> ### Aliases: ARMAacf
> ### Keywords: ts
> 
> ### ** Examples
> 
> ARMAacf(c(1.0, -0.25), 1.0, lag.max = 10)
          0           1           2           3           4           5 
1.000000000 0.875000000 0.625000000 0.406250000 0.250000000 0.148437500 
          6           7           8           9          10 
0.085937500 0.048828125 0.027343750 0.015136719 0.008300781 
> 
> ## Example from Brockwell & Davis (1991, pp.92-4)
> ## answer: 2^(-n) * (32/3 + 8 * n) /(32/3)
> n <- 1:10
> a.n <- 2^(-n) * (32/3 + 8 * n) /(32/3)
> (A.n <- ARMAacf(c(1.0, -0.25), 1.0, lag.max = 10))
          0           1           2           3           4           5 
1.000000000 0.875000000 0.625000000 0.406250000 0.250000000 0.148437500 
          6           7           8           9          10 
0.085937500 0.048828125 0.027343750 0.015136719 0.008300781 
> stopifnot(all.equal(unname(A.n), c(1, a.n)))
> 
> ARMAacf(c(1.0, -0.25), 1.0, lag.max = 10, pacf = TRUE)
 [1]  0.8750000 -0.6000000  0.3750000 -0.2727273  0.2142857 -0.1764706
 [7]  0.1500000 -0.1304348  0.1153846 -0.1034483
> zapsmall(ARMAacf(c(1.0, -0.25), lag.max = 10, pacf = TRUE))
 [1]  0.80 -0.25  0.00  0.00  0.00  0.00  0.00  0.00  0.00  0.00
> 
> ## Cov-Matrix of length-7 sub-sample of AR(1) example:
> toeplitz(ARMAacf(0.8, lag.max = 7))
          [,1]     [,2]    [,3]   [,4]   [,5]    [,6]     [,7]      [,8]
[1,] 1.0000000 0.800000 0.64000 0.5120 0.4096 0.32768 0.262144 0.2097152
[2,] 0.8000000 1.000000 0.80000 0.6400 0.5120 0.40960 0.327680 0.2621440
[3,] 0.6400000 0.800000 1.00000 0.8000 0.6400 0.51200 0.409600 0.3276800
[4,] 0.5120000 0.640000 0.80000 1.0000 0.8000 0.64000 0.512000 0.4096000
[5,] 0.4096000 0.512000 0.64000 0.8000 1.0000 0.80000 0.640000 0.5120000
[6,] 0.3276800 0.409600 0.51200 0.6400 0.8000 1.00000 0.800000 0.6400000
[7,] 0.2621440 0.327680 0.40960 0.5120 0.6400 0.80000 1.000000 0.8000000
[8,] 0.2097152 0.262144 0.32768 0.4096 0.5120 0.64000 0.800000 1.0000000
> 
> 
> 
> cleanEx()
> nameEx("ARMAtoMA")
> ### * ARMAtoMA
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ARMAtoMA
> ### Title: Convert ARMA Process to Infinite MA Process
> ### Aliases: ARMAtoMA
> ### Keywords: ts
> 
> ### ** Examples
> 
> ARMAtoMA(c(1.0, -0.25), 1.0, 10)
 [1] 2.00000000 1.75000000 1.25000000 0.81250000 0.50000000 0.29687500
 [7] 0.17187500 0.09765625 0.05468750 0.03027344
> ## Example from Brockwell & Davis (1991, p.92)
> ## answer (1 + 3*n)*2^(-n)
> n <- 1:10; (1 + 3*n)*2^(-n)
 [1] 2.00000000 1.75000000 1.25000000 0.81250000 0.50000000 0.29687500
 [7] 0.17187500 0.09765625 0.05468750 0.03027344
> 
> 
> 
> cleanEx()
> nameEx("Beta")
> ### * Beta
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Beta
> ### Title: The Beta Distribution
> ### Aliases: Beta dbeta pbeta qbeta rbeta
> ### Keywords: distribution
> 
> ### ** Examples
> 
> x <- seq(0, 1, length.out = 21)
> dbeta(x, 1, 1)
 [1] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
> pbeta(x, 1, 1)
 [1] 0.00 0.05 0.10 0.15 0.20 0.25 0.30 0.35 0.40 0.45 0.50 0.55 0.60 0.65 0.70
[16] 0.75 0.80 0.85 0.90 0.95 1.00
> 
> ## Visualization, including limit cases:
> pl.beta <- function(a,b, asp = if(isLim) 1, ylim = if(isLim) c(0,1.1)) {
+   if(isLim <- a == 0 || b == 0 || a == Inf || b == Inf) {
+     eps <- 1e-10
+     x <- c(0, eps, (1:7)/16, 1/2+c(-eps,0,eps), (9:15)/16, 1-eps, 1)
+   } else {
+     x <- seq(0, 1, length.out = 1025)
+   }
+   fx <- cbind(dbeta(x, a,b), pbeta(x, a,b), qbeta(x, a,b))
+   f <- fx; f[fx == Inf] <- 1e100
+   matplot(x, f, ylab="", type="l", ylim=ylim, asp=asp,
+           main = sprintf("[dpq]beta(x, a=%g, b=%g)", a,b))
+   abline(0,1,     col="gray", lty=3)
+   abline(h = 0:1, col="gray", lty=3)
+   legend("top", paste0(c("d","p","q"), "beta(x, a,b)"),
+          col=1:3, lty=1:3, bty = "n")
+   invisible(cbind(x, fx))
+ }
> pl.beta(3,1)
> 
> pl.beta(2, 4)
> pl.beta(3, 7)
> pl.beta(3, 7, asp=1)
> 
> pl.beta(0, 0)   ## point masses at  {0, 1}
> 
> pl.beta(0, 2)   ## point mass at 0 ; the same as
> pl.beta(1, Inf)
> 
> pl.beta(Inf, 2) ## point mass at 1 ; the same as
> pl.beta(3, 0)
> 
> pl.beta(Inf, Inf)# point mass at 1/2
> 
> 
> 
> cleanEx()
> nameEx("Binomial")
> ### * Binomial
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Binomial
> ### Title: The Binomial Distribution
> ### Aliases: Binomial dbinom pbinom qbinom rbinom
> ### Keywords: distribution
> 
> ### ** Examples
> 
> require(graphics)
> # Compute P(45 < X < 55) for X Binomial(100,0.5)
> sum(dbinom(46:54, 100, 0.5))
[1] 0.6317984
> 
> ## Using "log = TRUE" for an extended range :
> n <- 2000
> k <- seq(0, n, by = 20)
> plot (k, dbinom(k, n, pi/10, log = TRUE), type = "l", ylab = "log density",
+       main = "dbinom(*, log=TRUE) is better than  log(dbinom(*))")
> lines(k, log(dbinom(k, n, pi/10)), col = "red", lwd = 2)
> ## extreme points are omitted since dbinom gives 0.
> mtext("dbinom(k, log=TRUE)", adj = 0)
> mtext("extended range", adj = 0, line = -1, font = 4)
> mtext("log(dbinom(k))", col = "red", adj = 1)
> 
> 
> 
> cleanEx()
> nameEx("Cauchy")
> ### * Cauchy
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Cauchy
> ### Title: The Cauchy Distribution
> ### Aliases: Cauchy dcauchy pcauchy qcauchy rcauchy
> ### Keywords: distribution
> 
> ### ** Examples
> 
> dcauchy(-1:4)
[1] 0.15915494 0.31830989 0.15915494 0.06366198 0.03183099 0.01872411
> 
> 
> 
> cleanEx()
> nameEx("Chisquare")
> ### * Chisquare
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Chisquare
> ### Title: The (non-central) Chi-Squared Distribution
> ### Aliases: Chisquare dchisq pchisq qchisq rchisq
> ### Keywords: distribution
> 
> ### ** Examples
> 
> require(graphics)
> 
> dchisq(1, df = 1:3)
[1] 0.2419707 0.3032653 0.2419707
> pchisq(1, df =  3)
[1] 0.198748
> pchisq(1, df =  3, ncp = 0:4)  # includes the above
[1] 0.19874804 0.13229855 0.08787311 0.05824691 0.03853592
> 
> x <- 1:10
> ## Chi-squared(df = 2) is a special exponential distribution
> all.equal(dchisq(x, df = 2), dexp(x, 1/2))
[1] TRUE
> all.equal(pchisq(x, df = 2), pexp(x, 1/2))
[1] TRUE
> 
> ## non-central RNG -- df = 0 with ncp > 0:  Z0 has point mass at 0!
> Z0 <- rchisq(100, df = 0, ncp = 2.)
> graphics::stem(Z0)

  The decimal point is at the |

  0 | 0000000000000000000000000000000000000013356778899
  1 | 0001333456678888899
  2 | 0011444467
  3 | 00233345888
  4 | 111246
  5 | 
  6 | 
  7 | 178
  8 | 23

> 
> 
> ## "analytical" test
> lam <- seq(0, 100, by = .25)
> p00 <- pchisq(0,      df = 0, ncp = lam)
> p.0 <- pchisq(1e-300, df = 0, ncp = lam)
> stopifnot(all.equal(p00, exp(-lam/2)),
+           all.equal(p.0, exp(-lam/2)))
> 
> 
> 
> cleanEx()
> nameEx("Exponential")
> ### * Exponential
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Exponential
> ### Title: The Exponential Distribution
> ### Aliases: Exponential dexp pexp qexp rexp
> ### Keywords: distribution
> 
> ### ** Examples
> 
> dexp(1) - exp(-1) #-> 0
[1] 0
> 
> ## a fast way to generate *sorted*  U[0,1]  random numbers:
> rsunif <- function(n) { n1 <- n+1
+    cE <- cumsum(rexp(n1)); cE[seq_len(n)]/cE[n1] }
> plot(rsunif(1000), ylim=0:1, pch=".")
> abline(0,1/(1000+1), col=adjustcolor(1, 0.5))
> 
> 
> 
> cleanEx()
> nameEx("Fdist")
> ### * Fdist
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: FDist
> ### Title: The F Distribution
> ### Aliases: FDist df pf qf rf
> ### Keywords: distribution
> 
> ### ** Examples
> 
> ## Equivalence of pt(.,nu) with pf(.^2, 1,nu):
> x <- seq(0.001, 5, length.out = 100)
> nu <- 4
> stopifnot(all.equal(2*pt(x,nu) - 1, pf(x^2, 1,nu)),
+           ## upper tails:
+  	  all.equal(2*pt(x,     nu, lower.tail=FALSE),
+ 		      pf(x^2, 1,nu, lower.tail=FALSE)))
> 
> ## the density of the square of a t_m is 2*dt(x, m)/(2*x)
> # check this is the same as the density of F_{1,m}
> all.equal(df(x^2, 1, 5), dt(x, 5)/x)
[1] TRUE
> 
> ## Identity:  qf(2*p - 1, 1, df) == qt(p, df)^2  for  p >= 1/2
> p <- seq(1/2, .99, length.out = 50); df <- 10
> rel.err <- function(x, y) ifelse(x == y, 0, abs(x-y)/mean(abs(c(x,y))))
> 
> 
> 
> cleanEx()
> nameEx("GammaDist")
> ### * GammaDist
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: GammaDist
> ### Title: The Gamma Distribution
> ### Aliases: GammaDist dgamma pgamma qgamma rgamma
> ### Keywords: distribution
> 
> ### ** Examples
> 
> -log(dgamma(1:4, shape = 1))
[1] 1 2 3 4
> p <- (1:9)/10
> pgamma(qgamma(p, shape = 2), shape = 2)
[1] 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9
> 1 - 1/exp(qgamma(p, shape = 1))
[1] 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9
> 
> 
> 
> cleanEx()
> nameEx("Geometric")
> ### * Geometric
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Geometric
> ### Title: The Geometric Distribution
> ### Aliases: Geometric dgeom pgeom qgeom rgeom
> ### Keywords: distribution
> 
> ### ** Examples
> 
> qgeom((1:9)/10, prob = .2)
[1]  0  0  1  2  3  4  5  7 10
> Ni <- rgeom(20, prob = 1/4); table(factor(Ni, 0:max(Ni)))

 0  1  2  3  4  5  6  7  8  9 10 11 
 5  3  3  1  2  2  0  1  0  1  1  1 
> 
> 
> 
> cleanEx()
> nameEx("HoltWinters")
> ### * HoltWinters
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: HoltWinters
> ### Title: Holt-Winters Filtering
> ### Aliases: HoltWinters print.HoltWinters residuals.HoltWinters
> ### Keywords: ts
> 
> ### ** Examples
> 
> ## Don't show: 
> od <- options(digits = 5)
> ## End(Don't show)
> require(graphics)
> 
> ## Seasonal Holt-Winters
> (m <- HoltWinters(co2))
Holt-Winters exponential smoothing with trend and additive seasonal component.

Call:
HoltWinters(x = co2)

Smoothing parameters:
 alpha: 0.51265
 beta : 0.0094977
 gamma: 0.47289

Coefficients:
         [,1]
a   364.76162
b     0.12474
s1    0.22153
s2    0.95528
s3    1.59847
s4    2.87580
s5    3.28201
s6    2.44070
s7    0.89694
s8   -1.37964
s9   -3.41124
s10  -3.25702
s11  -1.91349
s12  -0.58442
> plot(m)
> plot(fitted(m))
> 
> (m <- HoltWinters(AirPassengers, seasonal = "mult"))
Holt-Winters exponential smoothing with trend and multiplicative seasonal component.

Call:
HoltWinters(x = AirPassengers, seasonal = "mult")

Smoothing parameters:
 alpha: 0.27559
 beta : 0.032693
 gamma: 0.87073

Coefficients:
         [,1]
a   469.32322
b     3.02154
s1    0.94646
s2    0.88292
s3    0.97174
s4    1.03048
s5    1.04769
s6    1.18053
s7    1.35908
s8    1.33317
s9    1.10834
s10   0.98688
s11   0.83613
s12   0.92099
> plot(m)
> 
> ## Non-Seasonal Holt-Winters
> x <- uspop + rnorm(uspop, sd = 5)
> m <- HoltWinters(x, gamma = FALSE)
> plot(m)
> 
> ## Exponential Smoothing
> m2 <- HoltWinters(x, gamma = FALSE, beta = FALSE)
> lines(fitted(m2)[,1], col = 3)
> ## Don't show: 
> options(od)
> ## End(Don't show)
> 
> 
> 
> cleanEx()
> nameEx("Hypergeometric")
> ### * Hypergeometric
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Hypergeometric
> ### Title: The Hypergeometric Distribution
> ### Aliases: Hypergeometric dhyper phyper qhyper rhyper
> ### Keywords: distribution
> 
> ### ** Examples
> 
> m <- 10; n <- 7; k <- 8
> x <- 0:(k+1)
> rbind(phyper(x, m, n, k), dhyper(x, m, n, k))
     [,1]         [,2]       [,3]     [,4]      [,5]      [,6]      [,7]
[1,]    0 0.0004113534 0.01336898 0.117030 0.4193747 0.7821884 0.9635952
[2,]    0 0.0004113534 0.01295763 0.103661 0.3023447 0.3628137 0.1814068
           [,8]       [,9] [,10]
[1,] 0.99814891 1.00000000     1
[2,] 0.03455368 0.00185109     0
> all(phyper(x, m, n, k) == cumsum(dhyper(x, m, n, k)))  # FALSE
[1] FALSE
> 
> 
> cleanEx()
> nameEx("IQR")
> ### * IQR
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: IQR
> ### Title: The Interquartile Range
> ### Aliases: IQR
> ### Keywords: univar robust distribution
> 
> ### ** Examples
> 
> IQR(rivers)
[1] 370
> 
> 
> 
> cleanEx()
> nameEx("KalmanLike")
> ### * KalmanLike
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: KalmanLike
> ### Title: Kalman Filtering
> ### Aliases: KalmanLike KalmanRun KalmanSmooth KalmanForecast makeARIMA
> ### Keywords: ts
> 
> ### ** Examples
> 
> ## an ARIMA fit
> fit3 <- arima(presidents, c(3, 0, 0))
> predict(fit3, 12)
$pred
         Qtr1     Qtr2     Qtr3     Qtr4
1975 29.84194 34.41014 39.30815 43.02779
1976 46.18808 48.56947 50.44866 51.86064
1977 52.94295 53.75521 54.37019 54.83150

$se
         Qtr1     Qtr2     Qtr3     Qtr4
1975  9.00655 11.25606 13.43389 14.51516
1976 15.25538 15.65611 15.90158 16.03792
1977 16.11764 16.16229 16.18785 16.20220

> ## reconstruct this
> pr <- KalmanForecast(12, fit3$model)
> pr$pred + fit3$coef[4]
 [1] 29.84194 34.41014 39.30815 43.02779 46.18808 48.56947 50.44866 51.86064
 [9] 52.94295 53.75521 54.37019 54.83150
> sqrt(pr$var * fit3$sigma2)
 [1]  9.00655 11.25606 13.43389 14.51516 15.25538 15.65611 15.90158 16.03792
 [9] 16.11764 16.16229 16.18785 16.20220
> ## and now do it year by year
> mod <- fit3$model
> for(y in 1:3) {
+   pr <- KalmanForecast(4, mod, TRUE)
+   print(list(pred = pr$pred + fit3$coef["intercept"], 
+              se = sqrt(pr$var * fit3$sigma2)))
+   mod <- attr(pr, "mod")
+ }
$pred
[1] 29.84194 34.41014 39.30815 43.02779

$se
[1]  9.00655 11.25606 13.43389 14.51516

$pred
[1] 46.18808 48.56947 50.44866 51.86064

$se
[1] 15.25538 15.65611 15.90158 16.03792

$pred
[1] 52.94295 53.75521 54.37019 54.83150

$se
[1] 16.11764 16.16229 16.18785 16.20220

> 
> 
> 
> cleanEx()
> nameEx("Logistic")
> ### * Logistic
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Logistic
> ### Title: The Logistic Distribution
> ### Aliases: Logistic dlogis plogis qlogis rlogis
> ### Keywords: distribution
> 
> ### ** Examples
> 
> var(rlogis(4000, 0, scale = 5))  # approximately (+/- 3)
[1] 86.93007
> pi^2/3 * 5^2
[1] 82.2467
> 
> 
> 
> cleanEx()
> nameEx("Lognormal")
> ### * Lognormal
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Lognormal
> ### Title: The Log Normal Distribution
> ### Aliases: Lognormal dlnorm plnorm qlnorm rlnorm
> ### Keywords: distribution
> 
> ### ** Examples
> 
> dlnorm(1) == dnorm(0)
[1] TRUE
> 
> 
> 
> cleanEx()
> nameEx("Multinom")
> ### * Multinom
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Multinom
> ### Title: The Multinomial Distribution
> ### Aliases: Multinomial rmultinom dmultinom
> ### Keywords: distribution
> 
> ### ** Examples
> 
> rmultinom(10, size = 12, prob = c(0.1,0.2,0.8))
     [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
[1,]    0    1    0    3    1    0    1    2    2     1
[2,]    2    4    4    2    0    1    2    2    5     3
[3,]   10    7    8    7   11   11    9    8    5     8
> 
> pr <- c(1,3,6,10) # normalization not necessary for generation
> rmultinom(10, 20, prob = pr)
     [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
[1,]    3    0    0    0    1    1    1    1    1     1
[2,]    1    2    3    3    2    4    3    4    4     4
[3,]    7    6    9    7    8    3    8    6    2     7
[4,]    9   12    8   10    9   12    8    9   13     8
> 
> ## all possible outcomes of Multinom(N = 3, K = 3)
> X <- t(as.matrix(expand.grid(0:3, 0:3))); X <- X[, colSums(X) <= 3]
> X <- rbind(X, 3:3 - colSums(X)); dimnames(X) <- list(letters[1:3], NULL)
> X
  [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
a    0    1    2    3    0    1    2    0    1     0
b    0    0    0    0    1    1    1    2    2     3
c    3    2    1    0    2    1    0    1    0     0
> round(apply(X, 2, function(x) dmultinom(x, prob = c(1,2,5))), 3)
 [1] 0.244 0.146 0.029 0.002 0.293 0.117 0.012 0.117 0.023 0.016
> 
> 
> 
> cleanEx()
> nameEx("NLSstAsymptotic")
> ### * NLSstAsymptotic
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: NLSstAsymptotic
> ### Title: Fit the Asymptotic Regression Model
> ### Aliases: NLSstAsymptotic NLSstAsymptotic.sortedXyData
> ### Keywords: manip
> 
> ### ** Examples
> 
> Lob.329 <- Loblolly[ Loblolly$Seed == "329", ]
> print(NLSstAsymptotic(sortedXyData(expression(age),
+                                    expression(height),
+                                    Lob.329)), digits = 3)
    b0     b1    lrc 
 -8.25 102.38  -3.22 
> 
> 
> 
> cleanEx()
> nameEx("NLSstClosestX")
> ### * NLSstClosestX
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: NLSstClosestX
> ### Title: Inverse Interpolation
> ### Aliases: NLSstClosestX NLSstClosestX.sortedXyData
> ### Keywords: manip
> 
> ### ** Examples
> 
> DNase.2 <- DNase[ DNase$Run == "2", ]
> DN.srt <- sortedXyData(expression(log(conc)), expression(density), DNase.2)
> NLSstClosestX(DN.srt, 1.0)
[1] 0.9795406
> 
> 
> 
> cleanEx()
> nameEx("NLSstLfAsymptote")
> ### * NLSstLfAsymptote
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: NLSstLfAsymptote
> ### Title: Horizontal Asymptote on the Left Side
> ### Aliases: NLSstLfAsymptote NLSstLfAsymptote.sortedXyData
> ### Keywords: manip
> 
> ### ** Examples
> 
> DNase.2 <- DNase[ DNase$Run == "2", ]
> DN.srt <- sortedXyData( expression(log(conc)), expression(density), DNase.2 )
> NLSstLfAsymptote( DN.srt )
[1] -0.1869375
> 
> 
> 
> cleanEx()
> nameEx("NLSstRtAsymptote")
> ### * NLSstRtAsymptote
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: NLSstRtAsymptote
> ### Title: Horizontal Asymptote on the Right Side
> ### Aliases: NLSstRtAsymptote NLSstRtAsymptote.sortedXyData
> ### Keywords: manip
> 
> ### ** Examples
> 
> DNase.2 <- DNase[ DNase$Run == "2", ]
> DN.srt <- sortedXyData( expression(log(conc)), expression(density), DNase.2 )
> NLSstRtAsymptote( DN.srt )
[1] 2.157437
> 
> 
> 
> cleanEx()
> nameEx("NegBinomial")
> ### * NegBinomial
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: NegBinomial
> ### Title: The Negative Binomial Distribution
> ### Aliases: NegBinomial dnbinom pnbinom qnbinom rnbinom
> ### Keywords: distribution
> 
> ### ** Examples
> 
> require(graphics)
> x <- 0:11
> dnbinom(x, size = 1, prob = 1/2) * 2^(1 + x) # == 1
 [1] 1 1 1 1 1 1 1 1 1 1 1 1
> 126 /  dnbinom(0:8, size  = 2, prob  = 1/2) #- theoretically integer
[1]   504.0   504.0   672.0  1008.0  1612.8  2688.0  4608.0  8064.0 14336.0
> 
> 
> x <- 0:15
> size <- (1:20)/4
> persp(x, size, dnb <- outer(x, size, function(x,s) dnbinom(x, s, prob = 0.4)),
+       xlab = "x", ylab = "s", zlab = "density", theta = 150)
> title(tit <- "negative binomial density(x,s, pr = 0.4)  vs.  x & s")
> 
> image  (x, size, log10(dnb), main = paste("log [", tit, "]"))
> contour(x, size, log10(dnb), add = TRUE)
> 
> ## Alternative parametrization
> x1 <- rnbinom(500, mu = 4, size = 1)
> x2 <- rnbinom(500, mu = 4, size = 10)
> x3 <- rnbinom(500, mu = 4, size = 100)
> h1 <- hist(x1, breaks = 20, plot = FALSE)
> h2 <- hist(x2, breaks = h1$breaks, plot = FALSE)
> h3 <- hist(x3, breaks = h1$breaks, plot = FALSE)
> barplot(rbind(h1$counts, h2$counts, h3$counts),
+         beside = TRUE, col = c("red","blue","cyan"),
+         names.arg = round(h1$breaks[-length(h1$breaks)]))
> 
> 
> 
> cleanEx()
> nameEx("Normal")
> ### * Normal
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Normal
> ### Title: The Normal Distribution
> ### Aliases: Normal dnorm pnorm qnorm rnorm
> ### Keywords: distribution
> 
> ### ** Examples
> 
> require(graphics)
> 
> dnorm(0) == 1/sqrt(2*pi)
[1] TRUE
> dnorm(1) == exp(-1/2)/sqrt(2*pi)
[1] TRUE
> dnorm(1) == 1/sqrt(2*pi*exp(1))
[1] TRUE
> 
> ## Using "log = TRUE" for an extended range :
> par(mfrow = c(2,1))
> plot(function(x) dnorm(x, log = TRUE), -60, 50,
+      main = "log { Normal density }")
> curve(log(dnorm(x)), add = TRUE, col = "red", lwd = 2)
> mtext("dnorm(x, log=TRUE)", adj = 0)
> mtext("log(dnorm(x))", col = "red", adj = 1)
> 
> plot(function(x) pnorm(x, log.p = TRUE), -50, 10,
+      main = "log { Normal Cumulative }")
> curve(log(pnorm(x)), add = TRUE, col = "red", lwd = 2)
> mtext("pnorm(x, log=TRUE)", adj = 0)
> mtext("log(pnorm(x))", col = "red", adj = 1)
> 
> ## if you want the so-called 'error function'
> erf <- function(x) 2 * pnorm(x * sqrt(2)) - 1
> ## (see Abramowitz and Stegun 29.2.29)
> ## and the so-called 'complementary error function'
> erfc <- function(x) 2 * pnorm(x * sqrt(2), lower = FALSE)
> ## and the inverses
> erfinv <- function (x) qnorm((1 + x)/2)/sqrt(2)
> erfcinv <- function (x) qnorm(x/2, lower = FALSE)/sqrt(2)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("Poisson")
> ### * Poisson
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Poisson
> ### Title: The Poisson Distribution
> ### Aliases: Poisson dpois ppois qpois rpois
> ### Keywords: distribution
> 
> ### ** Examples
> 
> require(graphics)
> 
> -log(dpois(0:7, lambda = 1) * gamma(1+ 0:7)) # == 1
[1] 1 1 1 1 1 1 1 1
> Ni <- rpois(50, lambda = 4); table(factor(Ni, 0:max(Ni)))

 0  1  2  3  4  5  6  7  8  9 10 
 1  2  7  9  8 13  5  4  0  0  1 
> 
> 1 - ppois(10*(15:25), lambda = 100)  # becomes 0 (cancellation)
 [1] 1.233094e-06 1.261664e-08 7.085799e-11 2.252643e-13 4.440892e-16
 [6] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00
[11] 0.000000e+00
>     ppois(10*(15:25), lambda = 100, lower.tail = FALSE)  # no cancellation
 [1] 1.233094e-06 1.261664e-08 7.085800e-11 2.253110e-13 4.174239e-16
 [6] 4.626179e-19 3.142097e-22 1.337219e-25 3.639328e-29 6.453883e-33
[11] 7.587807e-37
> 
> par(mfrow = c(2, 1))
> x <- seq(-0.01, 5, 0.01)
> plot(x, ppois(x, 1), type = "s", ylab = "F(x)", main = "Poisson(1) CDF")
> plot(x, pbinom(x, 100, 0.01), type = "s", ylab = "F(x)",
+      main = "Binomial(100, 0.01) CDF")
> 
> ## The (limit) case  lambda = 0 :
> stopifnot(identical(dpois(0,0), 1),
+ 	  identical(ppois(0,0), 1),
+ 	  identical(qpois(1,0), 0))
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("SSD")
> ### * SSD
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: SSD
> ### Title: SSD Matrix and Estimated Variance Matrix in Multivariate Models
> ### Aliases: SSD estVar
> ### Keywords: models multivariate
> 
> ### ** Examples
> 
> # Lifted from Baron+Li:
> # "Notes on the use of R for psychology experiments and questionnaires"
> # Maxwell and Delaney, p. 497
> reacttime <- matrix(c(
+ 420, 420, 480, 480, 600, 780,
+ 420, 480, 480, 360, 480, 600,
+ 480, 480, 540, 660, 780, 780,
+ 420, 540, 540, 480, 780, 900,
+ 540, 660, 540, 480, 660, 720,
+ 360, 420, 360, 360, 480, 540,
+ 480, 480, 600, 540, 720, 840,
+ 480, 600, 660, 540, 720, 900,
+ 540, 600, 540, 480, 720, 780,
+ 480, 420, 540, 540, 660, 780),
+ ncol = 6, byrow = TRUE,
+ dimnames = list(subj = 1:10,
+               cond = c("deg0NA", "deg4NA", "deg8NA",
+                        "deg0NP", "deg4NP", "deg8NP")))
> 
> mlmfit <- lm(reacttime ~ 1)
> SSD(mlmfit)
$SSD
        cond
cond     deg0NA deg4NA deg8NA deg0NP deg4NP deg8NP
  deg0NA  29160  30600  26640  23760  32400  25560
  deg4NA  30600  66600  32400   7200  36000  30600
  deg8NA  26640  32400  56160  41040  57600  69840
  deg0NP  23760   7200  41040  70560  72000  63360
  deg4NP  32400  36000  57600  72000 108000 100800
  deg8NP  25560  30600  69840  63360 100800 122760

$call
lm(formula = reacttime ~ 1)

$df
[1] 9

attr(,"class")
[1] "SSD"
> estVar(mlmfit)
        cond
cond     deg0NA deg4NA deg8NA deg0NP deg4NP deg8NP
  deg0NA   3240   3400   2960   2640   3600   2840
  deg4NA   3400   7400   3600    800   4000   3400
  deg8NA   2960   3600   6240   4560   6400   7760
  deg0NP   2640    800   4560   7840   8000   7040
  deg4NP   3600   4000   6400   8000  12000  11200
  deg8NP   2840   3400   7760   7040  11200  13640
> 
> 
> 
> cleanEx()
> nameEx("SSasymp")
> ### * SSasymp
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: SSasymp
> ### Title: Self-Starting Nls Asymptotic Regression Model
> ### Aliases: SSasymp
> ### Keywords: models
> 
> ### ** Examples
> 
> ## Don't show: 
> options(show.nls.convergence=FALSE)
> ## End(Don't show)
> Lob.329 <- Loblolly[ Loblolly$Seed == "329", ]
> SSasymp( Lob.329$age, 100, -8.5, -3.2 )   # response only
[1]  3.988924 11.505611 27.822517 41.130854 51.985354 60.838463
> local({
+   Asym <- 100 ; resp0 <- -8.5 ; lrc <- -3.2
+   SSasymp( Lob.329$age, Asym, resp0, lrc) # response _and_ gradient
+ })
[1]  3.988924 11.505611 27.822517 41.130854 51.985354 60.838463
attr(,"gradient")
          Asym     resp0      lrc
[1,] 0.1151053 0.8848947 11.74087
[2,] 0.1843835 0.8156165 18.03613
[3,] 0.3347697 0.6652303 29.42113
[4,] 0.4574272 0.5425728 35.99454
[5,] 0.5574687 0.4425313 39.14366
[6,] 0.6390642 0.3609358 39.90776
> getInitial(height ~ SSasymp( age, Asym, resp0, lrc), data = Lob.329)
     Asym     resp0       lrc 
94.128204 -8.250753 -3.217578 
> ## Initial values are in fact the converged values
> fm1 <- nls(height ~ SSasymp( age, Asym, resp0, lrc), data = Lob.329)
> summary(fm1)

Formula: height ~ SSasymp(age, Asym, resp0, lrc)

Parameters:
      Estimate Std. Error t value Pr(>|t|)    
Asym   94.1282     8.4030  11.202 0.001525 ** 
resp0  -8.2508     1.2261  -6.729 0.006700 ** 
lrc    -3.2176     0.1386 -23.218 0.000175 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 0.7493 on 3 degrees of freedom

> 
> ## Visualize the SSasymp()  model  parametrization :
> 
>   xx <- seq(-.3, 5, length.out = 101)
>   ##  Asym + (R0-Asym) * exp(-exp(lrc)* x) :
>   yy <- 5 - 4 * exp(-xx / exp(3/4))
>   stopifnot( all.equal(yy, SSasymp(xx, Asym = 5, R0 = 1, lrc = -3/4)) )
>   require(graphics)
>   op <- par(mar = c(0, .2, 4.1, 0))
>   plot(xx, yy, type = "l", axes = FALSE, ylim = c(0,5.2), xlim = c(-.3, 5),
+        xlab = "", ylab = "", lwd = 2,
+        main = quote("Parameters in the SSasymp model " ~
+                     {f[phi](x) == phi[1] + (phi[2]-phi[1])*~e^{-e^{phi[3]}*~x}}))
>   mtext(quote(list(phi[1] == "Asym", phi[2] == "R0", phi[3] == "lrc")))
>   usr <- par("usr")
>   arrows(usr[1], 0, usr[2], 0, length = 0.1, angle = 25)
>   arrows(0, usr[3], 0, usr[4], length = 0.1, angle = 25)
>   text(usr[2] - 0.2, 0.1, "x", adj = c(1, 0))
>   text(     -0.1, usr[4], "y", adj = c(1, 1))
>   abline(h = 5, lty = 3)
>   arrows(c(0.35, 0.65), 1,
+          c(0  ,  1   ), 1, length = 0.08, angle = 25); text(0.5, 1, quote(1))
>   y0 <- 1 + 4*exp(-3/4) ; t.5 <- log(2) / exp(-3/4) ; AR2 <- 3 # (Asym + R0)/2
>   segments(c(1, 1), c( 1, y0),
+            c(1, 0), c(y0,  1),  lty = 2, lwd = 0.75)
>   text(1.1, 1/2+y0/2, quote((phi[1]-phi[2])*e^phi[3]), adj = c(0,.5))
>   axis(2, at = c(1,AR2,5), labels= expression(phi[2], frac(phi[1]+phi[2],2), phi[1]),
+        pos=0, las=1)
>   arrows(c(.6,t.5-.6), AR2,
+          c(0, t.5   ), AR2, length = 0.08, angle = 25)
>   text(   t.5/2,   AR2, quote(t[0.5]))
>   text(   t.5 +.4, AR2,
+        quote({f(t[0.5]) == frac(phi[1]+phi[2],2)}~{} %=>% {}~~
+                 {t[0.5] == frac(log(2), e^{phi[3]})}), adj = c(0, 0.5))
>   par(op)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("SSasympOff")
> ### * SSasympOff
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: SSasympOff
> ### Title: Self-Starting Nls Asymptotic Regression Model with an Offset
> ### Aliases: SSasympOff
> ### Keywords: models
> 
> ### ** Examples
> 
> CO2.Qn1 <- CO2[CO2$Plant == "Qn1", ]
> SSasympOff(CO2.Qn1$conc, 32, -4, 43)  # response only
[1] 19.65412 29.14785 31.27791 31.88435 31.99259 31.99970 32.00000
> local({  Asym <- 32; lrc <- -4; c0 <- 43
+   SSasympOff(CO2.Qn1$conc, Asym, lrc, c0) # response and gradient
+ })
[1] 19.65412 29.14785 31.27791 31.88435 31.99259 31.99970 32.00000
attr(,"gradient")
          Asym          lrc            c0
[1,] 0.6141911 1.175838e+01 -2.261227e-01
[2,] 0.9108704 6.895531e+00 -5.223887e-02
[3,] 0.9774346 2.737698e+00 -1.322559e-02
[4,] 0.9963859 6.503026e-01 -2.118250e-03
[5,] 0.9997683 6.204920e-02 -1.357751e-04
[6,] 0.9999906 3.479529e-03 -5.505583e-06
[7,] 1.0000000 1.369435e-05 -1.430967e-08
> getInitial(uptake ~ SSasympOff(conc, Asym, lrc, c0), data = CO2.Qn1)
     Asym       lrc        c0 
38.139782 -4.380647 51.223238 
> ## Initial values are in fact the converged values
> fm1 <- nls(uptake ~ SSasympOff(conc, Asym, lrc, c0), data = CO2.Qn1)
> summary(fm1)

Formula: uptake ~ SSasympOff(conc, Asym, lrc, c0)

Parameters:
     Estimate Std. Error t value Pr(>|t|)    
Asym  38.1398     0.9164  41.620 1.99e-06 ***
lrc   -4.3806     0.2042 -21.457 2.79e-05 ***
c0    51.2232    11.6698   4.389   0.0118 *  
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 1.663 on 4 degrees of freedom

> 
> ## Visualize the SSasympOff()  model  parametrization :
> 
>   xx <- seq(0.25, 8,  by=1/16)
>   yy <- 5 * (1 -  exp(-(xx - 3/4)*0.4))
>   stopifnot( all.equal(yy, SSasympOff(xx, Asym = 5, lrc = log(0.4), c0 = 3/4)) )
>   require(graphics)
>   op <- par(mar = c(0, 0, 4.0, 0))
>   plot(xx, yy, type = "l", axes = FALSE, ylim = c(-.5,6), xlim = c(-1, 8),
+        xlab = "", ylab = "", lwd = 2,
+        main = "Parameters in the SSasympOff model")
>   mtext(quote(list(phi[1] == "Asym", phi[2] == "lrc", phi[3] == "c0")))
>   usr <- par("usr")
>   arrows(usr[1], 0, usr[2], 0, length = 0.1, angle = 25)
>   arrows(0, usr[3], 0, usr[4], length = 0.1, angle = 25)
>   text(usr[2] - 0.2, 0.1, "x", adj = c(1, 0))
>   text(     -0.1, usr[4], "y", adj = c(1, 1))
>   abline(h = 5, lty = 3)
>   arrows(-0.8, c(2.1, 2.9),
+          -0.8, c(0  , 5  ), length = 0.1, angle = 25)
>   text  (-0.8, 2.5, quote(phi[1]))
>   segments(3/4, -.2, 3/4, 1.6, lty = 2)
>   text    (3/4,    c(-.3, 1.7), quote(phi[3]))
>   arrows(c(1.1, 1.4), -.15,
+          c(3/4, 7/4), -.15, length = 0.07, angle = 25)
>   text    (3/4 + 1/2, -.15, quote(1))
>   segments(c(3/4, 7/4, 7/4), c(0, 0, 2),   # 5 * exp(log(0.4)) = 2
+            c(7/4, 7/4, 3/4), c(0, 2, 0),  lty = 2, lwd = 2)
>   text(      7/4 +.1, 2./2, quote(phi[1]*e^phi[2]), adj = c(0, .5))
>   par(op)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("SSasympOrig")
> ### * SSasympOrig
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: SSasympOrig
> ### Title: Self-Starting Nls Asymptotic Regression Model through the Origin
> ### Aliases: SSasympOrig
> ### Keywords: models
> 
> ### ** Examples
> 
> ## Visualize the SSasympOrig()  model  parametrization :
> 
>   xx <- seq(0, 5, length.out = 101)
>   yy <- 5 * (1- exp(-xx * log(2)))
>   stopifnot( all.equal(yy, SSasympOrig(xx, Asym = 5, lrc = log(log(2)))) )
> 
>   require(graphics)
>   op <- par(mar = c(0, 0, 3.5, 0))
>   plot(xx, yy, type = "l", axes = FALSE, ylim = c(0,5), xlim = c(-1/4, 5),
+        xlab = "", ylab = "", lwd = 2,
+        main = quote("Parameters in the SSasympOrig model"~~ f[phi](x)))
>   mtext(quote(list(phi[1] == "Asym", phi[2] == "lrc")))
>   usr <- par("usr")
>   arrows(usr[1], 0, usr[2], 0, length = 0.1, angle = 25)
>   arrows(0, usr[3], 0, usr[4], length = 0.1, angle = 25)
>   text(usr[2] - 0.2, 0.1, "x", adj = c(1, 0))
>   text(   -0.1,   usr[4], "y", adj = c(1, 1))
>   abline(h = 5, lty = 3)
>   axis(2, at = 5*c(1/2,1), labels= expression(frac(phi[1],2), phi[1]), pos=0, las=1)
>   arrows(c(.3,.7), 5/2,
+          c(0, 1 ), 5/2, length = 0.08, angle = 25)
>   text(   0.5,     5/2, quote(t[0.5]))
>   text(   1 +.4,   5/2,
+        quote({f(t[0.5]) == frac(phi[1],2)}~{} %=>% {}~~{t[0.5] == frac(log(2), e^{phi[2]})}),
+        adj = c(0, 0.5))
>   par(op)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("SSbiexp")
> ### * SSbiexp
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: SSbiexp
> ### Title: Self-Starting Nls Biexponential model
> ### Aliases: SSbiexp
> ### Keywords: models
> 
> ### ** Examples
> 
> Indo.1 <- Indometh[Indometh$Subject == 1, ]
> SSbiexp( Indo.1$time, 3, 1, 0.6, -1.3 )  # response only
 [1] 2.08098572 1.29421044 0.87967145 0.65483364 0.52711347 0.36094621
 [7] 0.26575722 0.20176113 0.15359129 0.11694936 0.06780767
> A1 <- 3; lrc1 <- 1; A2 <- 0.6; lrc2 <- -1.3
> SSbiexp( Indo.1$time, A1, lrc1, A2, lrc2 ) # response and gradient
 [1] 2.08098572 1.29421044 0.87967145 0.65483364 0.52711347 0.36094621
 [7] 0.26575722 0.20176113 0.15359129 0.11694936 0.06780767
attr(,"gradient")
                A1          lrc1        A2        lrc2
 [1,] 5.068347e-01 -1.033290e+00 0.9341363 -0.03818728
 [2,] 2.568814e-01 -1.047414e+00 0.8726106 -0.07134424
 [3,] 1.301964e-01 -7.962985e-01 0.8151372 -0.09996786
 [4,] 6.598804e-02 -5.381222e-01 0.7614492 -0.12451147
 [5,] 3.344502e-02 -3.409237e-01 0.7112973 -0.14538835
 [6,] 4.354421e-03 -7.101926e-02 0.5798049 -0.18961833
 [7,] 2.873397e-04 -7.029632e-03 0.4414920 -0.21657709
 [8,] 1.896098e-05 -6.184955e-04 0.3361737 -0.21988328
 [9,] 1.251198e-06 -5.101663e-05 0.2559792 -0.20928744
[10,] 8.256409e-08 -4.039784e-06 0.1949152 -0.19123411
[11,] 3.595188e-10 -2.345456e-08 0.1130128 -0.14783797
> print(getInitial(conc ~ SSbiexp(time, A1, lrc1, A2, lrc2), data = Indo.1),
+       digits = 5)
      A1     lrc1       A2     lrc2 
 2.02928  0.57939  0.19155 -1.78778 
> ## Initial values are in fact the converged values
> fm1 <- nls(conc ~ SSbiexp(time, A1, lrc1, A2, lrc2), data = Indo.1)
> summary(fm1)

Formula: conc ~ SSbiexp(time, A1, lrc1, A2, lrc2)

Parameters:
     Estimate Std. Error t value Pr(>|t|)    
A1     2.0293     0.1099  18.464 3.39e-07 ***
lrc1   0.5794     0.1247   4.648  0.00235 ** 
A2     0.1915     0.1106   1.731  0.12698    
lrc2  -1.7878     0.7871  -2.271  0.05737 .  
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 0.04103 on 7 degrees of freedom

> 
> ## Show the model components visually
>   require(graphics)
> 
>   xx <- seq(0, 5, length.out = 101)
>   y1 <- 3.5 * exp(-4*xx)
>   y2 <- 1.5 * exp(-xx)
>   plot(xx, y1 + y2, type = "l", lwd=2, ylim = c(-0.2,6), xlim = c(0, 5),
+        main = "Components of the SSbiexp model")
>   lines(xx, y1, lty = 2, col="tomato"); abline(v=0, h=0, col="gray40")
>   lines(xx, y2, lty = 3, col="blue2" )
>   legend("topright", c("y1+y2", "y1 = 3.5 * exp(-4*x)", "y2 = 1.5 * exp(-x)"),
+          lty=1:3, col=c("black","tomato","blue2"), bty="n")
>   axis(2, pos=0, at = c(3.5, 1.5), labels = c("A1","A2"), las=2)
> 
> ## and how you could have got their sum via SSbiexp():
>   ySS <- SSbiexp(xx, 3.5, log(4), 1.5, log(1))
>   ##                      ---          ---
>   stopifnot(all.equal(y1+y2, ySS, tolerance = 1e-15))
> 
> ## Show a no-noise example
> datN <- data.frame(time = (0:600)/64)
> datN$conc <- predict(fm1, newdata=datN)
> plot(conc ~ time, data=datN) # perfect, no noise
> ## IGNORE_RDIFF_BEGIN
> ## Fails by default (scaleOffset=0) on most platforms {also after increasing maxiter !}
> ## Not run: 
> ##D         nls(conc ~ SSbiexp(time, A1, lrc1, A2, lrc2), data = datN, trace=TRUE)
> ## End(Not run)
> ## Don't show: 
> try( # maxiter=10: store less garbage
+         nls(conc ~ SSbiexp(time, A1, lrc1, A2, lrc2), data = datN,
+             trace=TRUE, control = list(maxiter = 10)) )
0.01722077  (5.34e+02): par = (0.6168807 -1.783839 2.050204 0.2004597)
3.308944e-06 (1.13e+04): par = (0.5798674 -1.784335 2.028943 0.1920502)
2.571095e-11 (7.68e+06): par = (0.5793882 -1.78778 2.029276 0.1915479)
1.619248e-23 (5.90e+03): par = (0.5793887 -1.787785 2.029277 0.1915474)
1.243570e-28 (8.88e+00): par = (0.5793887 -1.787785 2.029277 0.1915474)
2.599121e-29 (1.38e+01): par = (0.5793887 -1.787785 2.029277 0.1915474)
1.292713e-29 (1.71e+00): par = (0.5793887 -1.787785 2.029277 0.1915474)
1.292713e-29 (1.71e+00): par = (0.5793887 -1.787785 2.029277 0.1915474)
1.292713e-29 (1.71e+00): par = (0.5793887 -1.787785 2.029277 0.1915474)
1.292713e-29 (1.71e+00): par = (0.5793887 -1.787785 2.029277 0.1915474)
1.292713e-29 (1.71e+00): par = (0.5793887 -1.787785 2.029277 0.1915474)
Error in nls(y ~ cbind(exp(-exp(lrc1) * x), exp(-exp(lrc2) * x)), data = xy,  : 
  number of iterations exceeded maximum of 10
> ## End(Don't show)
> fmX1 <- nls(conc ~ SSbiexp(time, A1, lrc1, A2, lrc2), data = datN, control = list(scaleOffset=1))
> fmX  <- nls(conc ~ SSbiexp(time, A1, lrc1, A2, lrc2), data = datN,
+            control = list(scaleOffset=1, printEval=TRUE, tol=1e-11, nDcentral=TRUE), trace=TRUE)
0.01722077    (6.55e-02): par = (0.6168807 -1.783839 2.050204 0.2004597)
  It.   1, fac=           1, eval (no.,total): ( 1,  1): new dev = 3.30894e-06
3.308942e-06  (9.08e-04): par = (0.5798674 -1.784335 2.028943 0.1920502)
  It.   2, fac=           1, eval (no.,total): ( 1,  2): new dev = 2.57108e-11
2.571082e-11  (2.53e-06): par = (0.5793882 -1.78778 2.029276 0.1915479)
  It.   3, fac=           1, eval (no.,total): ( 1,  3): new dev = 1.66996e-23
1.669964e-23  (2.04e-12): par = (0.5793887 -1.787785 2.029277 0.1915474)
1.671287e-23  (1.67e-13): par = (2.029277 0.5793887 0.1915474 -1.787785)
> all.equal(coef(fm1), coef(fmX1), tolerance=0) # ... rel.diff.: 1.57e-6
[1] "Mean relative difference: 1.574124e-06"
> all.equal(coef(fm1), coef(fmX),  tolerance=0) # ... rel.diff.: 1.03e-12
[1] "Mean relative difference: 1.032014e-12"
> ## IGNORE_RDIFF_END
> stopifnot(all.equal(coef(fm1), coef(fmX1), tolerance = 6e-6),
+           all.equal(coef(fm1), coef(fmX ), tolerance = 1e-11))
> 
> 
> 
> cleanEx()
> nameEx("SSfol")
> ### * SSfol
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: SSfol
> ### Title: Self-Starting Nls First-order Compartment Model
> ### Aliases: SSfol
> ### Keywords: models
> 
> ### ** Examples
> 
> Theoph.1 <- Theoph[ Theoph$Subject == 1, ]
> with(Theoph.1, SSfol(Dose, Time, -2.5, 0.5, -3)) # response only
 [1] 0.000000 2.214486 3.930988 5.261945 5.659813 5.084852 4.587699 3.916808
 [9] 3.318395 2.579204 0.943593
> with(Theoph.1, local({  lKe <- -2.5; lKa <- 0.5; lCl <- -3
+   SSfol(Dose, Time, lKe, lKa, lCl) # response _and_ gradient
+ }))
 [1] 0.000000 2.214486 3.930988 5.261945 5.659813 5.084852 4.587699 3.916808
 [9] 3.318395 2.579204 0.943593
attr(,"gradient")
            lKe         lKa       lCl
 [1,]  0.000000  0.00000000  0.000000
 [2,]  2.190284  1.78781716 -2.214486
 [3,]  3.825518  2.35519507 -3.930988
 [4,]  4.952713  1.75648252 -5.261945
 [5,]  4.976520  0.53458070 -5.659813
 [6,]  3.752822 -0.18560297 -5.084852
 [7,]  2.906859 -0.22729852 -4.587699
 [8,]  1.861771 -0.20447579 -3.916808
 [9,]  1.027129 -0.17383515 -3.318395
[10,]  0.148370 -0.13513891 -2.579204
[11,] -0.894541 -0.04944021 -0.943593
> getInitial(conc ~ SSfol(Dose, Time, lKe, lKa, lCl), data = Theoph.1)
      lKe       lKa       lCl 
-2.994845  0.609169 -3.971003 
> ## Initial values are in fact the converged values
> fm1 <- nls(conc ~ SSfol(Dose, Time, lKe, lKa, lCl), data = Theoph.1)
> summary(fm1)

Formula: conc ~ SSfol(Dose, Time, lKe, lKa, lCl)

Parameters:
    Estimate Std. Error t value Pr(>|t|)    
lKe  -2.9196     0.1709 -17.085 1.40e-07 ***
lKa   0.5752     0.1728   3.328   0.0104 *  
lCl  -3.9159     0.1273 -30.768 1.35e-09 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 0.732 on 8 degrees of freedom

> 
> 
> 
> cleanEx()
> nameEx("SSfpl")
> ### * SSfpl
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: SSfpl
> ### Title: Self-Starting Nls Four-Parameter Logistic Model
> ### Aliases: SSfpl
> ### Keywords: models
> 
> ### ** Examples
> 
> Chick.1 <- ChickWeight[ChickWeight$Chick == 1, ]
> SSfpl(Chick.1$Time, 13, 368, 14, 6)  # response only
 [1]  44.38189  55.31704  69.39853  87.05603 108.47420 133.43149 161.18758
 [8] 190.50000 219.81242 247.56851 272.52580 283.70240
> local({
+   A <- 13; B <- 368; xmid <- 14; scal <- 6
+   SSfpl(Chick.1$Time, A, B, xmid, scal) # response _and_ gradient
+ })
 [1]  44.38189  55.31704  69.39853  87.05603 108.47420 133.43149 161.18758
 [8] 190.50000 219.81242 247.56851 272.52580 283.70240
attr(,"gradient")
              A          B       xmid       scal
 [1,] 0.9116003 0.08839968  -4.767956  11.125231
 [2,] 0.8807971 0.11920292  -6.212120  12.424241
 [3,] 0.8411309 0.15886910  -7.906425  13.177374
 [4,] 0.7913915 0.20860853  -9.767885  13.023846
 [5,] 0.7310586 0.26894142 -11.632873  11.632873
 [6,] 0.6607564 0.33924363 -13.262646   8.841764
 [7,] 0.5825702 0.41742979 -14.388278   4.796093
 [8,] 0.5000000 0.50000000 -14.791667   0.000000
 [9,] 0.4174298 0.58257021 -14.388278  -4.796093
[10,] 0.3392436 0.66075637 -13.262646  -8.841764
[11,] 0.2689414 0.73105858 -11.632873 -11.632873
[12,] 0.2374580 0.76254197 -10.713410 -12.498978
> print(getInitial(weight ~ SSfpl(Time, A, B, xmid, scal), data = Chick.1),
+       digits = 5)
       A        B     xmid     scal 
 27.4532 348.9712  19.3905   6.6726 
> ## Initial values are in fact the converged values
> fm1 <- nls(weight ~ SSfpl(Time, A, B, xmid, scal), data = Chick.1)
> summary(fm1)

Formula: weight ~ SSfpl(Time, A, B, xmid, scal)

Parameters:
     Estimate Std. Error t value Pr(>|t|)    
A      27.453      6.601   4.159 0.003169 ** 
B     348.971     57.899   6.027 0.000314 ***
xmid   19.391      2.194   8.836 2.12e-05 ***
scal    6.673      1.002   6.662 0.000159 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 2.351 on 8 degrees of freedom

> 
> ## Visualizing the  SSfpl()  parametrization
>   xx <- seq(-0.5, 5, length.out = 101)
>   yy <- 1 + 4 / (1 + exp((2-xx))) # == SSfpl(xx, *) :
>   stopifnot( all.equal(yy, SSfpl(xx, A = 1, B = 5, xmid = 2, scal = 1)) )
>   require(graphics)
>   op <- par(mar = c(0, 0, 3.5, 0))
>   plot(xx, yy, type = "l", axes = FALSE, ylim = c(0,6), xlim = c(-1, 5),
+        xlab = "", ylab = "", lwd = 2,
+        main = "Parameters in the SSfpl model")
>   mtext(quote(list(phi[1] == "A", phi[2] == "B", phi[3] == "xmid", phi[4] == "scal")))
>   usr <- par("usr")
>   arrows(usr[1], 0, usr[2], 0, length = 0.1, angle = 25)
>   arrows(0, usr[3], 0, usr[4], length = 0.1, angle = 25)
>   text(usr[2] - 0.2, 0.1, "x", adj = c(1, 0))
>   text(     -0.1, usr[4], "y", adj = c(1, 1))
>   abline(h = c(1, 5), lty = 3)
>   arrows(-0.8, c(2.1, 2.9),
+          -0.8, c(0,   5  ), length = 0.1, angle = 25)
>   text  (-0.8, 2.5, quote(phi[1]))
>   arrows(-0.3, c(1/4, 3/4),
+          -0.3, c(0,   1  ), length = 0.07, angle = 25)
>   text  (-0.3, 0.5, quote(phi[2]))
>   text(2, -.1, quote(phi[3]))
>   segments(c(2,3,3), c(0,3,4), # SSfpl(x = xmid = 2) = 3
+            c(2,3,2), c(3,4,3),    lty = 2, lwd = 0.75)
>   arrows(c(2.3, 2.7), 3,
+          c(2.0, 3  ), 3, length = 0.08, angle = 25)
>   text(      2.5,     3, quote(phi[4])); text(3.1, 3.5, "1")
>   par(op)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("SSgompertz")
> ### * SSgompertz
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: SSgompertz
> ### Title: Self-Starting Nls Gompertz Growth Model
> ### Aliases: SSgompertz
> ### Keywords: models
> 
> ### ** Examples
> 
> DNase.1 <- subset(DNase, Run == 1)
> SSgompertz(log(DNase.1$conc), 4.5, 2.3, 0.7)  # response only
 [1] 0.00525729 0.00525729 0.07323255 0.07323255 0.18049064 0.18049064
 [7] 0.36508763 0.36508763 0.63288772 0.63288772 0.97257180 0.97257180
[13] 1.36033340 1.36033340 1.76786902 1.76786902
> local({  Asym <- 4.5; b2 <- 2.3; b3 <- 0.7
+   SSgompertz(log(DNase.1$conc), Asym, b2, b3) # response _and_ gradient
+ })
 [1] 0.00525729 0.00525729 0.07323255 0.07323255 0.18049064 0.18049064
 [7] 0.36508763 0.36508763 0.63288772 0.63288772 0.97257180 0.97257180
[13] 1.36033340 1.36033340 1.76786902 1.76786902
attr(,"gradient")
             Asym          b2         b3
 [1,] 0.001168287 -0.01543407  0.1531221
 [2,] 0.001168287 -0.01543407  0.1531221
 [3,] 0.016273900 -0.13112424  0.7036230
 [4,] 0.016273900 -0.13112424  0.7036230
 [5,] 0.040109031 -0.25238507  0.7795153
 [6,] 0.040109031 -0.25238507  0.7795153
 [7,] 0.081130585 -0.39869082  0.3233828
 [8,] 0.081130585 -0.39869082  0.3233828
 [9,] 0.140641716 -0.53975407 -0.7914802
[10,] 0.140641716 -0.53975407 -0.7914802
[11,] 0.216127067 -0.64777036 -2.4251586
[12,] 0.216127067 -0.64777036 -2.4251586
[13,] 0.302296311 -0.70757894 -4.2605728
[14,] 0.302296311 -0.70757894 -4.2605728
[15,] 0.392859783 -0.71814108 -5.9597255
[16,] 0.392859783 -0.71814108 -5.9597255
> print(getInitial(density ~ SSgompertz(log(conc), Asym, b2, b3),
+                  data = DNase.1), digits = 5)
   Asym      b2      b3 
4.60333 2.27134 0.71647 
> ## Initial values are in fact the converged values
> fm1 <- nls(density ~ SSgompertz(log(conc), Asym, b2, b3),
+            data = DNase.1)
> summary(fm1)

Formula: density ~ SSgompertz(log(conc), Asym, b2, b3)

Parameters:
     Estimate Std. Error t value Pr(>|t|)    
Asym  4.60333    0.65321   7.047 8.71e-06 ***
b2    2.27134    0.14373  15.803 7.24e-10 ***
b3    0.71647    0.02206  32.475 7.85e-14 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 0.02684 on 13 degrees of freedom

> plot(density ~ log(conc), DNase.1, # xlim = c(0, 21),
+      main = "SSgompertz() fit to DNase.1")
> ux <- par("usr")[1:2]; x <- seq(ux[1], ux[2], length.out=250)
> lines(x, do.call(SSgompertz, c(list(x=x), coef(fm1))), col = "red", lwd=2)
> As <- coef(fm1)[["Asym"]]; abline(v = 0, h = 0, lty = 3)
> axis(2, at= exp(-coef(fm1)[["b2"]]), quote(e^{-b[2]}), las=1, pos=0)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("SSlogis")
> ### * SSlogis
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: SSlogis
> ### Title: Self-Starting Nls Logistic Model
> ### Aliases: SSlogis
> ### Keywords: models
> 
> ### ** Examples
> 
> dwlg1 <- data.frame(Prop = c(rep(0,5), 2, 5, rep(9, 9)), end = 1:16)
> iPar <- getInitial(Prop ~ SSlogis(end, Asym, xmid, scal), data = dwlg1)
> ## failed in R <= 3.4.2 (because of the '0's in 'Prop')
> stopifnot(all.equal(tolerance = 1e-6,
+    iPar, c(Asym = 9.0678, xmid = 6.79331, scal = 0.499934)))
> 
> ## Visualize the SSlogis()  model  parametrization :
>   xx <- seq(-0.75, 5, by=1/32)
>   yy <- 5 / (1 + exp((2-xx)/0.6)) # == SSlogis(xx, *):
>   stopifnot( all.equal(yy, SSlogis(xx, Asym = 5, xmid = 2, scal = 0.6)) )
>   require(graphics)
>   op <- par(mar = c(0.5, 0, 3.5, 0))
>   plot(xx, yy, type = "l", axes = FALSE, ylim = c(0,6), xlim = c(-1, 5),
+        xlab = "", ylab = "", lwd = 2,
+        main = "Parameters in the SSlogis model")
>   mtext(quote(list(phi[1] == "Asym", phi[2] == "xmid", phi[3] == "scal")))
>   usr <- par("usr")
>   arrows(usr[1], 0, usr[2], 0, length = 0.1, angle = 25)
>   arrows(0, usr[3], 0, usr[4], length = 0.1, angle = 25)
>   text(usr[2] - 0.2, 0.1, "x", adj = c(1, 0))
>   text(     -0.1, usr[4], "y", adj = c(1, 1))
>   abline(h = 5, lty = 3)
>   arrows(-0.8, c(2.1, 2.9),
+          -0.8, c(0,   5  ), length = 0.1, angle = 25)
>   text  (-0.8, 2.5, quote(phi[1]))
>   segments(c(2,2.6,2.6), c(0,  2.5,3.5),   # NB.  SSlogis(x = xmid = 2) = 2.5
+            c(2,2.6,2  ), c(2.5,3.5,2.5), lty = 2, lwd = 0.75)
>   text(2, -.1, quote(phi[2]))
>   arrows(c(2.2, 2.4), 2.5,
+          c(2.0, 2.6), 2.5, length = 0.08, angle = 25)
>   text(      2.3,     2.5, quote(phi[3])); text(2.7, 3, "1")
>   par(op)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("SSmicmen")
> ### * SSmicmen
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: SSmicmen
> ### Title: Self-Starting Nls Michaelis-Menten Model
> ### Aliases: SSmicmen
> ### Keywords: models
> 
> ### ** Examples
> 
> PurTrt <- Puromycin[ Puromycin$state == "treated", ]
> SSmicmen(PurTrt$conc, 200, 0.05)  # response only
 [1]  57.14286  57.14286 109.09091 109.09091 137.50000 137.50000 162.96296
 [8] 162.96296 183.60656 183.60656 191.30435 191.30435
> local({  Vm <- 200; K <- 0.05
+   SSmicmen(PurTrt$conc, Vm, K)    # response _and_ gradient
+ })
 [1]  57.14286  57.14286 109.09091 109.09091 137.50000 137.50000 162.96296
 [8] 162.96296 183.60656 183.60656 191.30435 191.30435
attr(,"gradient")
             Vm         K
 [1,] 0.2857143 -816.3265
 [2,] 0.2857143 -816.3265
 [3,] 0.5454545 -991.7355
 [4,] 0.5454545 -991.7355
 [5,] 0.6875000 -859.3750
 [6,] 0.6875000 -859.3750
 [7,] 0.8148148 -603.5665
 [8,] 0.8148148 -603.5665
 [9,] 0.9180328 -300.9944
[10,] 0.9180328 -300.9944
[11,] 0.9565217 -166.3516
[12,] 0.9565217 -166.3516
> print(getInitial(rate ~ SSmicmen(conc, Vm, K), data = PurTrt), digits = 3)
      Vm        K 
212.6837   0.0641 
> ## Initial values are in fact the converged values
> fm1 <- nls(rate ~ SSmicmen(conc, Vm, K), data = PurTrt)
> summary(fm1)

Formula: rate ~ SSmicmen(conc, Vm, K)

Parameters:
    Estimate Std. Error t value Pr(>|t|)    
Vm 2.127e+02  6.947e+00  30.615 3.24e-11 ***
K  6.412e-02  8.281e-03   7.743 1.57e-05 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 10.93 on 10 degrees of freedom

> ## Alternative call using the subset argument
> fm2 <- nls(rate ~ SSmicmen(conc, Vm, K), data = Puromycin,
+            subset = state == "treated")
> summary(fm2) # The same indeed:

Formula: rate ~ SSmicmen(conc, Vm, K)

Parameters:
    Estimate Std. Error t value Pr(>|t|)    
Vm 2.127e+02  6.947e+00  30.615 3.24e-11 ***
K  6.412e-02  8.281e-03   7.743 1.57e-05 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 10.93 on 10 degrees of freedom

> stopifnot(all.equal(coef(summary(fm1)), coef(summary(fm2))))
> 
> ## Visualize the SSmicmen()  Michaelis-Menton model parametrization :
> 
>   xx <- seq(0, 5, length.out = 101)
>   yy <- 5 * xx/(1+xx)
>   stopifnot(all.equal(yy, SSmicmen(xx, Vm = 5, K = 1)))
>   require(graphics)
>   op <- par(mar = c(0, 0, 3.5, 0))
>   plot(xx, yy, type = "l", lwd = 2, ylim = c(-1/4,6), xlim = c(-1, 5),
+        ann = FALSE, axes = FALSE, main = "Parameters in the SSmicmen model")
>   mtext(quote(list(phi[1] == "Vm", phi[2] == "K")))
>   usr <- par("usr")
>   arrows(usr[1], 0, usr[2], 0, length = 0.1, angle = 25)
>   arrows(0, usr[3], 0, usr[4], length = 0.1, angle = 25)
>   text(usr[2] - 0.2, 0.1, "x", adj = c(1, 0))
>   text(     -0.1, usr[4], "y", adj = c(1, 1))
>   abline(h = 5, lty = 3)
>   arrows(-0.8, c(2.1, 2.9),
+          -0.8, c(0,   5  ),  length = 0.1, angle = 25)
>   text(  -0.8,     2.5, quote(phi[1]))
>   segments(1, 0, 1, 2.7, lty = 2, lwd = 0.75)
>   text(1, 2.7, quote(phi[2]))
>   par(op)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("SSweibull")
> ### * SSweibull
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: SSweibull
> ### Title: Self-Starting Nls Weibull Growth Curve Model
> ### Aliases: SSweibull
> ### Keywords: models
> 
> ### ** Examples
> 
> Chick.6 <- subset(ChickWeight, (Chick == 6) & (Time > 0))
> SSweibull(Chick.6$Time, 160, 115, -5.5, 2.5)   # response only
 [1]  47.62811  59.09743  79.79756 105.12008 128.41818 145.02585 154.25783
 [8] 158.24919 159.58222 159.92314 159.97023
> local({ Asym <- 160; Drop <- 115; lrc <- -5.5; pwr <- 2.5
+   SSweibull(Chick.6$Time, Asym, Drop, lrc, pwr) # response _and_ gradient
+ })
 [1]  47.62811  59.09743  79.79756 105.12008 128.41818 145.02585 154.25783
 [8] 158.24919 159.58222 159.92314 159.97023
attr(,"gradient")
      Asym          Drop        lrc        pwr
 [1,]    1 -0.9771469094  2.5978438  1.8006881
 [2,]    1 -0.8774136912 13.1957043 18.2931305
 [3,]    1 -0.6974125358 28.9032091 51.7875987
 [4,]    1 -0.4772166721 40.5993205 84.4239136
 [5,]    1 -0.2746244909 40.8147795 93.9795029
 [6,]    1 -0.1302099955 30.5264027 75.8552610
 [7,]    1 -0.0499319343 17.2098335 45.4177374
 [8,]    1 -0.0152244293  7.3268815 20.3144290
 [9,]    1 -0.0036328431  2.3469622  6.7835933
[10,]    1 -0.0006683898  0.5619310  1.6833949
[11,]    1 -0.0002589123  0.2459116  0.7486834
> ## IGNORE_RDIFF_BEGIN
> getInitial(weight ~ SSweibull(Time, Asym, Drop, lrc, pwr), data = Chick.6)
      Asym       Drop        lrc        pwr 
158.501204 110.997081  -5.993421   2.646141 
> ## IGNORE_RDIFF_END
> ## Initial values are in fact the converged values
> fm1 <- nls(weight ~ SSweibull(Time, Asym, Drop, lrc, pwr), data = Chick.6)
> summary(fm1)

Formula: weight ~ SSweibull(Time, Asym, Drop, lrc, pwr)

Parameters:
     Estimate Std. Error t value Pr(>|t|)    
Asym 158.5012     1.1769  134.67 3.28e-13 ***
Drop 110.9971     2.6330   42.16 1.10e-09 ***
lrc   -5.9934     0.3733  -16.05 8.83e-07 ***
pwr    2.6461     0.1613   16.41 7.62e-07 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 2.061 on 7 degrees of freedom

> ## Data and Fit:
> plot(weight ~ Time, Chick.6, xlim = c(0, 21), main = "SSweibull() fit to Chick.6")
> ux <- par("usr")[1:2]; x <- seq(ux[1], ux[2], length.out=250)
> lines(x, do.call(SSweibull, c(list(x=x), coef(fm1))), col = "red", lwd=2)
> As <- coef(fm1)[["Asym"]]; abline(v = 0, h = c(As, As - coef(fm1)[["Drop"]]), lty = 3)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("SignRank")
> ### * SignRank
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: SignRank
> ### Title: Distribution of the Wilcoxon Signed Rank Statistic
> ### Aliases: SignRank dsignrank psignrank qsignrank rsignrank
> ### Keywords: distribution
> 
> ### ** Examples
> 
> require(graphics)
> 
> par(mfrow = c(2,2))
> for(n in c(4:5,10,40)) {
+   x <- seq(0, n*(n+1)/2, length.out = 501)
+   plot(x, dsignrank(x, n = n), type = "l",
+        main = paste0("dsignrank(x, n = ", n, ")"))
+ }
> ## Don't show: 
> p <- c(1, 1, 1, 2, 2:6, 8, 10, 11, 13, 15, 17, 20, 22, 24,
+        27, 29, 31, 33, 35, 36, 38, 39, 39, 40)
> stopifnot(round(dsignrank(0:56, n = 10)* 2^10) == c(p, rev(p), 0),
+           qsignrank((1:16)/ 16, n = 4) == c(0:2, rep(3:7, each = 2), 8:10))
> ## End(Don't show)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("StructTS")
> ### * StructTS
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: StructTS
> ### Title: Fit Structural Time Series
> ### Aliases: StructTS print.StructTS predict.StructTS
> ### Keywords: ts
> 
> ### ** Examples
> 
> ## see also JohnsonJohnson, Nile and AirPassengers
> require(graphics)
> 
> trees <- window(treering, start = 0)
> (fit <- StructTS(trees, type = "level"))

Call:
StructTS(x = trees, type = "level")

Variances:
  level  epsilon  
0.00037  0.07199  
> plot(trees)
> lines(fitted(fit), col = "green")
> tsdiag(fit)
> 
> (fit <- StructTS(log10(UKgas), type = "BSM"))

Call:
StructTS(x = log10(UKgas), type = "BSM")

Variances:
    level      slope       seas    epsilon  
0.000e+00  1.733e-05  7.137e-04  3.678e-04  
> par(mfrow = c(4, 1)) # to give appropriate aspect ratio for next plot.
> plot(log10(UKgas))
> plot(cbind(fitted(fit), resids=resid(fit)), main = "UK gas consumption")
> 
> ## keep some parameters fixed; trace optimizer:
> StructTS(log10(UKgas), type = "BSM", fixed = c(0.1,0.001,NA,NA),
+          optim.control = list(trace = TRUE))
iter   10 value -0.936176
final  value -0.936176 
converged

Call:
StructTS(x = log10(UKgas), type = "BSM", fixed = c(0.1, 0.001, NA, NA), optim.control = list(trace = TRUE))

Variances:
    level      slope       seas    epsilon  
0.1000000  0.0010000  0.0003012  0.0000000  
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("TDist")
> ### * TDist
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: TDist
> ### Title: The Student t Distribution
> ### Aliases: TDist dt pt qt rt
> ### Keywords: distribution
> 
> ### ** Examples
> 
> require(graphics)
> 
> 1 - pt(1:5, df = 1)
[1] 0.25000000 0.14758362 0.10241638 0.07797913 0.06283296
> qt(.975, df = c(1:10,20,50,100,1000))
 [1] 12.706205  4.302653  3.182446  2.776445  2.570582  2.446912  2.364624
 [8]  2.306004  2.262157  2.228139  2.085963  2.008559  1.983972  1.962339
> 
> tt <- seq(0, 10, length.out = 21)
> ncp <- seq(0, 6, length.out = 31)
> ptn <- outer(tt, ncp, function(t, d) pt(t, df = 3, ncp = d))
> t.tit <- "Non-central t - Probabilities"
> image(tt, ncp, ptn, zlim = c(0,1), main = t.tit)
> persp(tt, ncp, ptn, zlim = 0:1, r = 2, phi = 20, theta = 200, main = t.tit,
+       xlab = "t", ylab = "non-centrality parameter",
+       zlab = "Pr(T <= t)")
> 
> plot(function(x) dt(x, df = 3, ncp = 2), -3, 11, ylim = c(0, 0.32),
+      main = "Non-central t - Density", yaxs = "i")
> 
> 
> 
> cleanEx()
> nameEx("Tukey")
> ### * Tukey
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Tukey
> ### Title: The Studentized Range Distribution
> ### Aliases: Tukey ptukey qtukey
> ### Keywords: distribution
> 
> ### ** Examples
> 
> if(interactive())
+   curve(ptukey(x, nm = 6, df = 5), from = -1, to = 8, n = 101)
> (ptt <- ptukey(0:10, 2, df =  5))
 [1] 0.0000000 0.4889159 0.7835628 0.9126407 0.9632574 0.9833586 0.9918510
 [8] 0.9957141 0.9976011 0.9985838 0.9991249
> (qtt <- qtukey(.95, 2, df =  2:11))
 [1] 6.079637 4.500659 3.926503 3.635351 3.460456 3.344084 3.261182 3.199173
 [9] 3.151064 3.112663
> ## The precision may be not much more than about 8 digits:
> 
> 
> 
> cleanEx()
> nameEx("TukeyHSD")
> ### * TukeyHSD
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: TukeyHSD
> ### Title: Compute Tukey Honest Significant Differences
> ### Aliases: TukeyHSD
> ### Keywords: models design
> 
> ### ** Examples
> 
> require(graphics)
> 
> summary(fm1 <- aov(breaks ~ wool + tension, data = warpbreaks))
            Df Sum Sq Mean Sq F value  Pr(>F)   
wool         1    451   450.7   3.339 0.07361 . 
tension      2   2034  1017.1   7.537 0.00138 **
Residuals   50   6748   135.0                   
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
> TukeyHSD(fm1, "tension", ordered = TRUE)
  Tukey multiple comparisons of means
    95% family-wise confidence level
    factor levels have been ordered

Fit: aov(formula = breaks ~ wool + tension, data = warpbreaks)

$tension
         diff        lwr      upr     p adj
M-H  4.722222 -4.6311985 14.07564 0.4474210
L-H 14.722222  5.3688015 24.07564 0.0011218
L-M 10.000000  0.6465793 19.35342 0.0336262

> plot(TukeyHSD(fm1, "tension"))
> 
> 
> 
> cleanEx()
> nameEx("Uniform")
> ### * Uniform
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Uniform
> ### Title: The Uniform Distribution
> ### Aliases: Uniform dunif punif qunif runif
> ### Keywords: distribution
> 
> ### ** Examples
> 
> u <- runif(20)
> 
> ## The following relations always hold :
> punif(u) == u
 [1] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
[16] TRUE TRUE TRUE TRUE TRUE
> dunif(u) == 1
 [1] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
[16] TRUE TRUE TRUE TRUE TRUE
> 
> var(runif(10000))  #- ~ = 1/12 = .08333
[1] 0.08475621
> 
> 
> 
> cleanEx()
> nameEx("Weibull")
> ### * Weibull
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Weibull
> ### Title: The Weibull Distribution
> ### Aliases: Weibull dweibull pweibull qweibull rweibull
> ### Keywords: distribution
> 
> ### ** Examples
> 
> x <- c(0, rlnorm(50))
> all.equal(dweibull(x, shape = 1), dexp(x))
[1] TRUE
> all.equal(pweibull(x, shape = 1, scale = pi), pexp(x, rate = 1/pi))
[1] TRUE
> ## Cumulative hazard H():
> all.equal(pweibull(x, 2.5, pi, lower.tail = FALSE, log.p = TRUE),
+           -(x/pi)^2.5, tolerance = 1e-15)
[1] TRUE
> all.equal(qweibull(x/11, shape = 1, scale = pi), qexp(x/11, rate = 1/pi))
[1] TRUE
> 
> 
> 
> cleanEx()
> nameEx("Wilcoxon")
> ### * Wilcoxon
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Wilcoxon
> ### Title: Distribution of the Wilcoxon Rank Sum Statistic
> ### Aliases: Wilcoxon dwilcox pwilcox qwilcox rwilcox
> ### Keywords: distribution
> 
> ### ** Examples
> 
> require(graphics)
> 
> x <- -1:(4*6 + 1)
> fx <- dwilcox(x, 4, 6)
> Fx <- pwilcox(x, 4, 6)
> 
> layout(rbind(1,2), widths = 1, heights = c(3,2))
> plot(x, fx, type = "h", col = "violet",
+      main =  "Probabilities (density) of Wilcoxon-Statist.(n=6, m=4)")
> plot(x, Fx, type = "s", col = "blue",
+      main =  "Distribution of Wilcoxon-Statist.(n=6, m=4)")
> abline(h = 0:1, col = "gray20", lty = 2)
> layout(1) # set back
> 
> N <- 200
> hist(U <- rwilcox(N, m = 4,n = 6), breaks = 0:25 - 1/2,
+      border = "red", col = "pink", sub = paste("N =",N))
> mtext("N * f(x),  f() = true \"density\"", side = 3, col = "blue")
>  lines(x, N*fx, type = "h", col = "blue", lwd = 2)
> points(x, N*fx, cex = 2)
> 
> ## Better is a Quantile-Quantile Plot
> qqplot(U, qw <- qwilcox((1:N - 1/2)/N, m = 4, n = 6),
+        main = paste("Q-Q-Plot of empirical and theoretical quantiles",
+                      "Wilcoxon Statistic,  (m=4, n=6)", sep = "\n"))
> n <- as.numeric(names(print(tU <- table(U))))
U
 0  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 
 1  2  4  5  5  5  7 12 13 14 12 23 16  9 13 16 13 11 14  1  1  2  1 
> text(n+.2, n+.5, labels = tU, col = "red")
> 
> 
> 
> cleanEx()
> nameEx("acf")
> ### * acf
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: acf
> ### Title: Auto- and Cross- Covariance and -Correlation Function Estimation
> ### Aliases: acf ccf pacf pacf.default [.acf
> ### Keywords: ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## Examples from Venables & Ripley
> acf(lh)
> acf(lh, type = "covariance")
> pacf(lh)
> 
> acf(ldeaths)
> acf(ldeaths, ci.type = "ma")
> acf(ts.union(mdeaths, fdeaths))
> ccf(mdeaths, fdeaths, ylab = "cross-correlation")
> # (just the cross-correlations)
> 
> presidents # contains missing values
     Qtr1 Qtr2 Qtr3 Qtr4
1945   NA   87   82   75
1946   63   50   43   32
1947   35   60   54   55
1948   36   39   NA   NA
1949   69   57   57   51
1950   45   37   46   39
1951   36   24   32   23
1952   25   32   NA   32
1953   59   74   75   60
1954   71   61   71   57
1955   71   68   79   73
1956   76   71   67   75
1957   79   62   63   57
1958   60   49   48   52
1959   57   62   61   66
1960   71   62   61   57
1961   72   83   71   78
1962   79   71   62   74
1963   76   64   62   57
1964   80   73   69   69
1965   71   64   69   62
1966   63   46   56   44
1967   44   52   38   46
1968   36   49   35   44
1969   59   65   65   56
1970   66   53   61   52
1971   51   48   54   49
1972   49   61   NA   NA
1973   68   44   40   27
1974   28   25   24   24
> acf(presidents, na.action = na.pass)
> pacf(presidents, na.action = na.pass)
> 
> 
> 
> cleanEx()
> nameEx("acf2AR")
> ### * acf2AR
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: acf2AR
> ### Title: Compute an AR Process Exactly Fitting an ACF
> ### Aliases: acf2AR
> ### Keywords: ts
> 
> ### ** Examples
> 
> (Acf <- ARMAacf(c(0.6, 0.3, -0.2)))
        0         1         2         3 
1.0000000 0.6923077 0.5769231 0.3538462 
> acf2AR(Acf)
              1      2    3
ar(1) 0.6923077 0.0000  0.0
ar(2) 0.5625000 0.1875  0.0
ar(3) 0.6000000 0.3000 -0.2
> 
> 
> 
> cleanEx()
> nameEx("add1")
> ### * add1
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: add1
> ### Title: Add or Drop All Possible Single Terms to a Model
> ### Aliases: add1 add1.default add1.lm add1.glm drop1 drop1.default
> ###   drop1.lm drop1.glm
> ### Keywords: models
> 
> ### ** Examples
> 
> ## Don't show: 
> od <- options(digits = 5)
> ## End(Don't show)
> require(graphics); require(utils)
> ## following example(swiss)
> lm1 <- lm(Fertility ~ ., data = swiss)
> add1(lm1, ~ I(Education^2) + .^2)
Single term additions

Model:
Fertility ~ Agriculture + Examination + Education + Catholic + 
    Infant.Mortality
                             Df Sum of Sq  RSS AIC
<none>                                    2105 191
I(Education^2)                1      11.8 2093 192
Agriculture:Examination       1      10.7 2094 192
Agriculture:Education         1       1.8 2103 193
Agriculture:Catholic          1      75.0 2030 191
Agriculture:Infant.Mortality  1       4.4 2101 193
Examination:Education         1      48.7 2056 192
Examination:Catholic          1      40.8 2064 192
Examination:Infant.Mortality  1      65.9 2039 191
Education:Catholic            1     278.2 1827 186
Education:Infant.Mortality    1      93.0 2012 191
Catholic:Infant.Mortality     1       2.4 2103 193
> drop1(lm1, test = "F")  # So called 'type II' anova
Single term deletions

Model:
Fertility ~ Agriculture + Examination + Education + Catholic + 
    Infant.Mortality
                 Df Sum of Sq  RSS AIC F value  Pr(>F)    
<none>                        2105 191                    
Agriculture       1       308 2413 195    5.99  0.0187 *  
Examination       1        53 2158 190    1.03  0.3155    
Education         1      1163 3268 209   22.64 2.4e-05 ***
Catholic          1       448 2553 198    8.72  0.0052 ** 
Infant.Mortality  1       409 2514 197    7.96  0.0073 ** 
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
> 
> ## following example(glm)
> ## Don't show: 
> example(glm, echo = FALSE)
> ## End(Don't show)
> drop1(glm.D93, test = "Chisq")
Single term deletions

Model:
counts ~ outcome + treatment
          Df Deviance  AIC  LRT Pr(>Chi)  
<none>           5.13 56.8                
outcome    2    10.58 58.2 5.45    0.065 .
treatment  2     5.13 52.8 0.00    1.000  
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
> drop1(glm.D93, test = "F")
Warning in drop1.glm(glm.D93, test = "F") :
  F test assumes 'quasipoisson' family
Single term deletions

Model:
counts ~ outcome + treatment
          Df Deviance  AIC F value Pr(>F)
<none>           5.13 56.8               
outcome    2    10.58 58.2    2.13   0.23
treatment  2     5.13 52.8    0.00   1.00
> add1(glm.D93, scope = ~outcome*treatment, test = "Rao") ## Pearson Chi-square
Single term additions

Model:
counts ~ outcome + treatment
                  Df Deviance  AIC Rao score Pr(>Chi)
<none>                   5.13 56.8                   
outcome:treatment  4     0.00 59.6      5.17     0.27
> ## Don't show: 
> options(od)
> ## End(Don't show)
> 
> 
> 
> cleanEx()
> nameEx("addmargins")
> ### * addmargins
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: addmargins
> ### Title: Puts Arbitrary Margins on Multidimensional Tables or Arrays
> ### Aliases: addmargins
> ### Keywords: manip array
> 
> ### ** Examples
> 
> Aye <- sample(c("Yes", "Si", "Oui"), 177, replace = TRUE)
> Bee <- sample(c("Hum", "Buzz"), 177, replace = TRUE)
> Sea <- sample(c("White", "Black", "Red", "Dead"), 177, replace = TRUE)
> (A <- table(Aye, Bee, Sea))
, , Sea = Black

     Bee
Aye   Buzz Hum
  Oui    7   4
  Si     5   7
  Yes    7   7

, , Sea = Dead

     Bee
Aye   Buzz Hum
  Oui    8   7
  Si    10   7
  Yes   10   3

, , Sea = Red

     Bee
Aye   Buzz Hum
  Oui    2  12
  Si     4   7
  Yes    8   7

, , Sea = White

     Bee
Aye   Buzz Hum
  Oui    7  12
  Si    13  10
  Yes    6   7

> (aA <- addmargins(A))
, , Sea = Black

     Bee
Aye   Buzz Hum Sum
  Oui    7   4  11
  Si     5   7  12
  Yes    7   7  14
  Sum   19  18  37

, , Sea = Dead

     Bee
Aye   Buzz Hum Sum
  Oui    8   7  15
  Si    10   7  17
  Yes   10   3  13
  Sum   28  17  45

, , Sea = Red

     Bee
Aye   Buzz Hum Sum
  Oui    2  12  14
  Si     4   7  11
  Yes    8   7  15
  Sum   14  26  40

, , Sea = White

     Bee
Aye   Buzz Hum Sum
  Oui    7  12  19
  Si    13  10  23
  Yes    6   7  13
  Sum   26  29  55

, , Sea = Sum

     Bee
Aye   Buzz Hum Sum
  Oui   24  35  59
  Si    32  31  63
  Yes   31  24  55
  Sum   87  90 177

> ## Don't show: 
> stopifnot(is.table(aA))
> ## End(Don't show)
> ftable(A)
         Sea Black Dead Red White
Aye Bee                          
Oui Buzz         7    8   2     7
    Hum          4    7  12    12
Si  Buzz         5   10   4    13
    Hum          7    7   7    10
Yes Buzz         7   10   8     6
    Hum          7    3   7     7
> ftable(aA)
         Sea Black Dead Red White Sum
Aye Bee                              
Oui Buzz         7    8   2     7  24
    Hum          4    7  12    12  35
    Sum         11   15  14    19  59
Si  Buzz         5   10   4    13  32
    Hum          7    7   7    10  31
    Sum         12   17  11    23  63
Yes Buzz         7   10   8     6  31
    Hum          7    3   7     7  24
    Sum         14   13  15    13  55
Sum Buzz        19   28  14    26  87
    Hum         18   17  26    29  90
    Sum         37   45  40    55 177
> 
> # Non-commutative functions - note differences between resulting tables:
> ftable( addmargins(A, c(3, 1),
+                    FUN = list(list(Min = min, Max = max),
+                               Sum = sum)))
Margins computed over dimensions
in the following order:
1: Sea
2: Aye
         Sea Black Dead Red White Min Max
Aye Bee                                  
Oui Buzz         7    8   2     7   2   8
    Hum          4    7  12    12   4  12
Si  Buzz         5   10   4    13   4  13
    Hum          7    7   7    10   7  10
Yes Buzz         7   10   8     6   6  10
    Hum          7    3   7     7   3   7
Sum Buzz        19   28  14    26  12  31
    Hum         18   17  26    29  14  29
> ftable( addmargins(A, c(1, 3),
+                    FUN = list(Sum = sum,
+                               list(Min = min, Max = max))))
Margins computed over dimensions
in the following order:
1: Aye
2: Sea
         Sea Black Dead Red White Min Max
Aye Bee                                  
Oui Buzz         7    8   2     7   2   8
    Hum          4    7  12    12   4  12
Si  Buzz         5   10   4    13   4  13
    Hum          7    7   7    10   7  10
Yes Buzz         7   10   8     6   6  10
    Hum          7    3   7     7   3   7
Sum Buzz        19   28  14    26  14  28
    Hum         18   17  26    29  17  29
> 
> # Weird function needed to return the N when computing percentages
> sqsm <- function(x) sum(x)^2/100
> B <- table(Sea, Bee)
> round(sweep(addmargins(B, 1, list(list(All = sum, N = sqsm))), 2,
+             apply(B, 2, sum)/100, `/`), 1)
       Bee
Sea      Buzz   Hum
  Black  21.8  20.0
  Dead   32.2  18.9
  Red    16.1  28.9
  White  29.9  32.2
  All   100.0 100.0
  N      87.0  90.0
> round(sweep(addmargins(B, 2, list(list(All = sum, N = sqsm))), 1,
+             apply(B, 1, sum)/100, `/`), 1)
       Bee
Sea      Buzz   Hum   All     N
  Black  51.4  48.6 100.0  37.0
  Dead   62.2  37.8 100.0  45.0
  Red    35.0  65.0 100.0  40.0
  White  47.3  52.7 100.0  55.0
> 
> # A total over Bee requires formation of the Bee-margin first:
> mB <-  addmargins(B, 2, FUN = list(list(Total = sum)))
> round(ftable(sweep(addmargins(mB, 1, list(list(All = sum, N = sqsm))), 2,
+                    apply(mB, 2, sum)/100, `/`)), 1)
      Bee  Buzz   Hum Total
Sea                        
Black      21.8  20.0  20.9
Dead       32.2  18.9  25.4
Red        16.1  28.9  22.6
White      29.9  32.2  31.1
All       100.0 100.0 100.0
N          87.0  90.0 177.0
> 
> ## Zero.Printing table+margins:
> set.seed(1)
> x <- sample( 1:7, 20, replace = TRUE)
> y <- sample( 1:7, 20, replace = TRUE)
> tx <- addmargins( table(x, y) )
> print(tx, zero.print = ".")
     y
x      1  2  3  4  5  6  7 Sum
  1    2  .  .  .  1  .  .   3
  2    2  1  .  .  .  1  .   4
  3    .  1  .  .  1  1  .   3
  4    .  .  .  .  .  .  1   1
  5    1  .  .  1  .  .  1   3
  6    .  .  1  1  1  .  .   3
  7    .  1  .  .  1  1  .   3
  Sum  5  3  1  2  4  3  2  20
> 
> 
> 
> cleanEx()
> nameEx("aggregate")
> ### * aggregate
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: aggregate
> ### Title: Compute Summary Statistics of Data Subsets
> ### Aliases: aggregate aggregate.default aggregate.data.frame
> ###   aggregate.formula aggregate.ts
> ### Keywords: category array
> 
> ### ** Examples
> 
> ## Compute the averages for the variables in 'state.x77', grouped
> ## according to the region (Northeast, South, North Central, West) that
> ## each state belongs to.
> aggregate(state.x77, list(Region = state.region), mean)
         Region Population   Income Illiteracy Life Exp    Murder  HS Grad
1     Northeast   5495.111 4570.222   1.000000 71.26444  4.722222 53.96667
2         South   4208.125 4011.938   1.737500 69.70625 10.581250 44.34375
3 North Central   4803.000 4611.083   0.700000 71.76667  5.275000 54.51667
4          West   2915.308 4702.615   1.023077 71.23462  7.215385 62.00000
     Frost      Area
1 132.7778  18141.00
2  64.6250  54605.12
3 138.8333  62652.00
4 102.1538 134463.00
> 
> ## Compute the averages according to region and the occurrence of more
> ## than 130 days of frost.
> aggregate(state.x77,
+           list(Region = state.region,
+                Cold = state.x77[,"Frost"] > 130),
+           mean)
         Region  Cold Population   Income Illiteracy Life Exp    Murder
1     Northeast FALSE  8802.8000 4780.400  1.1800000 71.12800  5.580000
2         South FALSE  4208.1250 4011.938  1.7375000 69.70625 10.581250
3 North Central FALSE  7233.8333 4633.333  0.7833333 70.95667  8.283333
4          West FALSE  4582.5714 4550.143  1.2571429 71.70000  6.828571
5     Northeast  TRUE  1360.5000 4307.500  0.7750000 71.43500  3.650000
6 North Central  TRUE  2372.1667 4588.833  0.6166667 72.57667  2.266667
7          West  TRUE   970.1667 4880.500  0.7500000 70.69167  7.666667
   HS Grad    Frost      Area
1 52.06000 110.6000  21838.60
2 44.34375  64.6250  54605.12
3 53.36667 120.0000  56736.50
4 60.11429  51.0000  91863.71
5 56.35000 160.5000  13519.00
6 55.66667 157.6667  68567.50
7 64.20000 161.8333 184162.17
> ## (Note that no state in 'South' is THAT cold.)
> 
> 
> ## example with character variables and NAs
> testDF <- data.frame(v1 = c(1,3,5,7,8,3,5,NA,4,5,7,9),
+                      v2 = c(11,33,55,77,88,33,55,NA,44,55,77,99) )
> by1 <- c("red", "blue", 1, 2, NA, "big", 1, 2, "red", 1, NA, 12)
> by2 <- c("wet", "dry", 99, 95, NA, "damp", 95, 99, "red", 99, NA, NA)
> aggregate(x = testDF, by = list(by1, by2), FUN = "mean")
  Group.1 Group.2 v1 v2
1       1      95  5 55
2       2      95  7 77
3       1      99  5 55
4       2      99 NA NA
5     big    damp  3 33
6    blue     dry  3 33
7     red     red  4 44
8     red     wet  1 11
> 
> # and if you want to treat NAs as a group
> fby1 <- factor(by1, exclude = "")
> fby2 <- factor(by2, exclude = "")
> aggregate(x = testDF, by = list(fby1, fby2), FUN = "mean")
   Group.1 Group.2  v1   v2
1        1      95 5.0 55.0
2        2      95 7.0 77.0
3        1      99 5.0 55.0
4        2      99  NA   NA
5      big    damp 3.0 33.0
6     blue     dry 3.0 33.0
7      red     red 4.0 44.0
8      red     wet 1.0 11.0
9       12    <NA> 9.0 99.0
10    <NA>    <NA> 7.5 82.5
> 
> 
> ## Formulas, one ~ one, one ~ many, many ~ one, and many ~ many:
> aggregate(weight ~ feed, data = chickwts, mean)
       feed   weight
1    casein 323.5833
2 horsebean 160.2000
3   linseed 218.7500
4  meatmeal 276.9091
5   soybean 246.4286
6 sunflower 328.9167
> aggregate(breaks ~ wool + tension, data = warpbreaks, mean)
  wool tension   breaks
1    A       L 44.55556
2    B       L 28.22222
3    A       M 24.00000
4    B       M 28.77778
5    A       H 24.55556
6    B       H 18.77778
> aggregate(cbind(Ozone, Temp) ~ Month, data = airquality, mean)
  Month    Ozone     Temp
1     5 23.61538 66.73077
2     6 29.44444 78.22222
3     7 59.11538 83.88462
4     8 59.96154 83.96154
5     9 31.44828 76.89655
> aggregate(cbind(ncases, ncontrols) ~ alcgp + tobgp, data = esoph, sum)
       alcgp    tobgp ncases ncontrols
1  0-39g/day 0-9g/day      9       252
2      40-79 0-9g/day     34       145
3     80-119 0-9g/day     19        42
4       120+ 0-9g/day     16         8
5  0-39g/day    10-19     10        74
6      40-79    10-19     17        68
7     80-119    10-19     19        30
8       120+    10-19     12         6
9  0-39g/day    20-29      5        37
10     40-79    20-29     15        47
11    80-119    20-29      6        10
12      120+    20-29      7         5
13 0-39g/day      30+      5        23
14     40-79      30+      9        20
15    80-119      30+      7         5
16      120+      30+     10         3
> 
> ## Dot notation:
> aggregate(. ~ Species, data = iris, mean)
     Species Sepal.Length Sepal.Width Petal.Length Petal.Width
1     setosa        5.006       3.428        1.462       0.246
2 versicolor        5.936       2.770        4.260       1.326
3  virginica        6.588       2.974        5.552       2.026
> aggregate(len ~ ., data = ToothGrowth, mean)
  supp dose   len
1   OJ  0.5 13.23
2   VC  0.5  7.98
3   OJ  1.0 22.70
4   VC  1.0 16.77
5   OJ  2.0 26.06
6   VC  2.0 26.14
> 
> ## Often followed by xtabs():
> ag <- aggregate(len ~ ., data = ToothGrowth, mean)
> xtabs(len ~ ., data = ag)
    dose
supp   0.5     1     2
  OJ 13.23 22.70 26.06
  VC  7.98 16.77 26.14
> 
> 
> ## Compute the average annual approval ratings for American presidents.
> aggregate(presidents, nfrequency = 1, FUN = mean)
Time Series:
Start = 1945 
End = 1974 
Frequency = 1 
 [1]    NA 47.00 51.00    NA 58.50 41.75 28.75    NA 67.00 65.00 72.75 72.25
[13] 65.25 52.25 61.50 62.75 76.00 71.50 64.75 72.75 66.50 52.25 45.00 41.00
[25] 61.25 58.00 50.50    NA 44.75 25.25
> ## Give the summer less weight.
> aggregate(presidents, nfrequency = 1,
+           FUN = weighted.mean, w = c(1, 1, 0.5, 1))
Time Series:
Start = 1945 
End = 1974 
Frequency = 1 
 [1]       NA 47.57143 50.57143       NA 58.71429 41.14286 28.28571       NA
 [9] 65.85714 64.14286 71.85714 73.00000 65.57143 52.85714 61.57143 63.00000
[17] 76.71429 72.85714 65.14286 73.28571 66.14286 51.71429 46.00000 41.85714
[25] 60.71429 57.57143 50.00000       NA 45.42857 25.42857
> 
> 
> 
> cleanEx()
> nameEx("alias")
> ### * alias
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: alias
> ### Title: Find Aliases (Dependencies) in a Model
> ### Aliases: alias alias.formula alias.lm
> ### Keywords: models
> 
> ### ** Examples
> 
> 
> cleanEx()
> nameEx("anova.glm")
> ### * anova.glm
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: anova.glm
> ### Title: Analysis of Deviance for Generalized Linear Model Fits
> ### Aliases: anova.glm
> ### Keywords: models regression
> 
> ### ** Examples
> 
> ## --- Continuing the Example from  '?glm':
> ## Don't show: 
> require(utils)
> example("glm", echo = FALSE)
> ## End(Don't show)
> anova(glm.D93)
Analysis of Deviance Table

Model: poisson, link: log

Response: counts

Terms added sequentially (first to last)


          Df Deviance Resid. Df Resid. Dev
NULL                          8    10.5814
outcome    2   5.4523         6     5.1291
treatment  2   0.0000         4     5.1291
> anova(glm.D93, test = "Cp")
Analysis of Deviance Table

Model: poisson, link: log

Response: counts

Terms added sequentially (first to last)


          Df Deviance Resid. Df Resid. Dev     Cp
NULL                          8    10.5814 12.581
outcome    2   5.4523         6     5.1291 11.129
treatment  2   0.0000         4     5.1291 15.129
> anova(glm.D93, test = "Chisq")
Analysis of Deviance Table

Model: poisson, link: log

Response: counts

Terms added sequentially (first to last)


          Df Deviance Resid. Df Resid. Dev Pr(>Chi)  
NULL                          8    10.5814           
outcome    2   5.4523         6     5.1291  0.06547 .
treatment  2   0.0000         4     5.1291  1.00000  
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
> glm.D93a <-
+    update(glm.D93, ~treatment*outcome) # equivalent to Pearson Chi-square
> anova(glm.D93, glm.D93a, test = "Rao")
Analysis of Deviance Table

Model 1: counts ~ outcome + treatment
Model 2: counts ~ treatment + outcome + treatment:outcome
  Resid. Df Resid. Dev Df Deviance    Rao Pr(>Chi)
1         4     5.1291                            
2         0     0.0000  4   5.1291 5.1732     0.27
> 
> 
> 
> cleanEx()
> nameEx("anova.lm")
> ### * anova.lm
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: anova.lm
> ### Title: ANOVA for Linear Model Fits
> ### Aliases: anova.lm anova.lmlist
> ### Keywords: regression models
> 
> ### ** Examples
> 
> ## sequential table
> fit <- lm(sr ~ ., data = LifeCycleSavings)
> anova(fit)
Analysis of Variance Table

Response: sr
          Df Sum Sq Mean Sq F value    Pr(>F)    
pop15      1 204.12 204.118 14.1157 0.0004922 ***
pop75      1  53.34  53.343  3.6889 0.0611255 .  
dpi        1  12.40  12.401  0.8576 0.3593551    
ddpi       1  63.05  63.054  4.3605 0.0424711 *  
Residuals 45 650.71  14.460                      
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
> 
> ## same effect via separate models
> fit0 <- lm(sr ~ 1, data = LifeCycleSavings)
> fit1 <- update(fit0, . ~ . + pop15)
> fit2 <- update(fit1, . ~ . + pop75)
> fit3 <- update(fit2, . ~ . + dpi)
> fit4 <- update(fit3, . ~ . + ddpi)
> anova(fit0, fit1, fit2, fit3, fit4, test = "F")
Analysis of Variance Table

Model 1: sr ~ 1
Model 2: sr ~ pop15
Model 3: sr ~ pop15 + pop75
Model 4: sr ~ pop15 + pop75 + dpi
Model 5: sr ~ pop15 + pop75 + dpi + ddpi
  Res.Df    RSS Df Sum of Sq       F    Pr(>F)    
1     49 983.63                                   
2     48 779.51  1   204.118 14.1157 0.0004922 ***
3     47 726.17  1    53.343  3.6889 0.0611255 .  
4     46 713.77  1    12.401  0.8576 0.3593551    
5     45 650.71  1    63.054  4.3605 0.0424711 *  
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
> 
> anova(fit4, fit2, fit0, test = "F") # unconventional order
Analysis of Variance Table

Model 1: sr ~ pop15 + pop75 + dpi + ddpi
Model 2: sr ~ pop15 + pop75
Model 3: sr ~ 1
  Res.Df    RSS Df Sum of Sq      F    Pr(>F)    
1     45 650.71                                  
2     47 726.17 -2   -75.455 2.6090 0.0847088 .  
3     49 983.63 -2  -257.460 8.9023 0.0005527 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
> 
> 
> 
> cleanEx()
> nameEx("anova.mlm")
> ### * anova.mlm
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: anova.mlm
> ### Title: Comparisons between Multivariate Linear Models
> ### Aliases: anova.mlm
> ### Keywords: regression models multivariate
> 
> ### ** Examples
> 
> require(graphics)
> utils::example(SSD) # Brings in the mlmfit and reacttime objects

SSD> # Lifted from Baron+Li:
SSD> # "Notes on the use of R for psychology experiments and questionnaires"
SSD> # Maxwell and Delaney, p. 497
SSD> reacttime <- matrix(c(
SSD+ 420, 420, 480, 480, 600, 780,
SSD+ 420, 480, 480, 360, 480, 600,
SSD+ 480, 480, 540, 660, 780, 780,
SSD+ 420, 540, 540, 480, 780, 900,
SSD+ 540, 660, 540, 480, 660, 720,
SSD+ 360, 420, 360, 360, 480, 540,
SSD+ 480, 480, 600, 540, 720, 840,
SSD+ 480, 600, 660, 540, 720, 900,
SSD+ 540, 600, 540, 480, 720, 780,
SSD+ 480, 420, 540, 540, 660, 780),
SSD+ ncol = 6, byrow = TRUE,
SSD+ dimnames = list(subj = 1:10,
SSD+               cond = c("deg0NA", "deg4NA", "deg8NA",
SSD+                        "deg0NP", "deg4NP", "deg8NP")))

SSD> mlmfit <- lm(reacttime ~ 1)

SSD> SSD(mlmfit)
$SSD
        cond
cond     deg0NA deg4NA deg8NA deg0NP deg4NP deg8NP
  deg0NA  29160  30600  26640  23760  32400  25560
  deg4NA  30600  66600  32400   7200  36000  30600
  deg8NA  26640  32400  56160  41040  57600  69840
  deg0NP  23760   7200  41040  70560  72000  63360
  deg4NP  32400  36000  57600  72000 108000 100800
  deg8NP  25560  30600  69840  63360 100800 122760

$call
lm(formula = reacttime ~ 1)

$df
[1] 9

attr(,"class")
[1] "SSD"

SSD> estVar(mlmfit)
        cond
cond     deg0NA deg4NA deg8NA deg0NP deg4NP deg8NP
  deg0NA   3240   3400   2960   2640   3600   2840
  deg4NA   3400   7400   3600    800   4000   3400
  deg8NA   2960   3600   6240   4560   6400   7760
  deg0NP   2640    800   4560   7840   8000   7040
  deg4NP   3600   4000   6400   8000  12000  11200
  deg8NP   2840   3400   7760   7040  11200  13640
> 
> mlmfit0 <- update(mlmfit, ~0)
> 
> ### Traditional tests of intrasubj. contrasts
> ## Using MANOVA techniques on contrasts:
> anova(mlmfit, mlmfit0, X = ~1)
Analysis of Variance Table

Model 1: reacttime ~ 1
Model 2: reacttime ~ 1 - 1

Contrasts orthogonal to
~1

  Res.Df Df Gen.var. Pillai approx F num Df den Df   Pr(>F)   
1      9      1249.6                                          
2     10  1   2013.2 0.9456   17.381      5      5 0.003534 **
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
> 
> ## Assuming sphericity
> anova(mlmfit, mlmfit0, X = ~1, test = "Spherical")
Analysis of Variance Table

Model 1: reacttime ~ 1
Model 2: reacttime ~ 1 - 1

Contrasts orthogonal to
~1

Greenhouse-Geisser epsilon: 0.4855
Huynh-Feldt epsilon:        0.6778

  Res.Df Df Gen.var.      F num Df den Df     Pr(>F)    G-G Pr    H-F Pr
1      9      1249.6                                                    
2     10  1   2013.2 38.028      5     45 4.4711e-15 2.532e-08 7.393e-11
> 
> 
> ### tests using intra-subject 3x2 design
> idata <- data.frame(deg = gl(3, 1, 6, labels = c(0, 4, 8)),
+                     noise = gl(2, 3, 6, labels = c("A", "P")))
> 
> anova(mlmfit, mlmfit0, X = ~ deg + noise,
+       idata = idata, test = "Spherical")
Analysis of Variance Table

Model 1: reacttime ~ 1
Model 2: reacttime ~ 1 - 1

Contrasts orthogonal to
~deg + noise

Greenhouse-Geisser epsilon: 0.904
Huynh-Feldt epsilon:        1.118

  Res.Df Df Gen.var.     F num Df den Df     Pr(>F)     G-G Pr     H-F Pr
1      9      316.58                                                     
2     10  1   996.34 45.31      2     18 9.4241e-08 3.4539e-07 9.4241e-08
> anova(mlmfit, mlmfit0, M = ~ deg + noise, X = ~ noise,
+       idata = idata, test = "Spherical" )
Analysis of Variance Table

Model 1: reacttime ~ 1
Model 2: reacttime ~ 1 - 1

Contrasts orthogonal to
~noise


Contrasts spanned by
~deg + noise

Greenhouse-Geisser epsilon: 0.9616
Huynh-Feldt epsilon:        1.2176

  Res.Df Df Gen.var.      F num Df den Df     Pr(>F)     G-G Pr     H-F Pr
1      9      1007.0                                                      
2     10  1   2703.2 40.719      2     18 2.0868e-07 3.4017e-07 2.0868e-07
> anova(mlmfit, mlmfit0, M = ~ deg + noise, X = ~ deg,
+       idata = idata, test = "Spherical" )
Analysis of Variance Table

Model 1: reacttime ~ 1
Model 2: reacttime ~ 1 - 1

Contrasts orthogonal to
~deg


Contrasts spanned by
~deg + noise

Greenhouse-Geisser epsilon: 1
Huynh-Feldt epsilon:        1

  Res.Df Df Gen.var.      F num Df den Df     Pr(>F)     G-G Pr     H-F Pr
1      9        1410                                                      
2     10  1     6030 33.766      1      9 0.00025597 0.00025597 0.00025597
> 
> f <- factor(rep(1:2, 5)) # bogus, just for illustration
> mlmfit2 <- update(mlmfit, ~f)
> anova(mlmfit2, mlmfit, mlmfit0, X = ~1, test = "Spherical")
Analysis of Variance Table

Model 1: reacttime ~ f
Model 2: reacttime ~ 1
Model 3: reacttime ~ 1 - 1

Contrasts orthogonal to
~1

Greenhouse-Geisser epsilon: 0.4691
Huynh-Feldt epsilon:        0.6758

  Res.Df Df Gen.var.       F num Df den Df  Pr(>F)  G-G Pr  H-F Pr
1      8      1337.3                                              
2      9  1   1249.6  0.2743      5     40 0.92452 0.79608 0.86456
3     10  1   2013.2 34.9615      5     40 0.00000 0.00000 0.00000
> anova(mlmfit2, X = ~1, test = "Spherical")
Analysis of Variance Table


Contrasts orthogonal to
~1

Greenhouse-Geisser epsilon: 0.4691
Huynh-Feldt epsilon:        0.6758

            Df       F num Df den Df  Pr(>F)  G-G Pr  H-F Pr
(Intercept)  1 34.9615      5     40 0.00000 0.00000 0.00000
f            1  0.2743      5     40 0.92452 0.79608 0.86456
Residuals    8                                              
> # one-model form, eqiv. to previous
> 
> ### There seems to be a strong interaction in these data
> plot(colMeans(reacttime))
> 
> 
> 
> cleanEx()
> nameEx("ansari.test")
> ### * ansari.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ansari.test
> ### Title: Ansari-Bradley Test
> ### Aliases: ansari.test ansari.test.default ansari.test.formula
> ### Keywords: htest
> 
> ### ** Examples
> 
> ## Hollander & Wolfe (1973, p. 86f):
> ## Serum iron determination using Hyland control sera
> ramsay <- c(111, 107, 100, 99, 102, 106, 109, 108, 104, 99,
+             101, 96, 97, 102, 107, 113, 116, 113, 110, 98)
> jung.parekh <- c(107, 108, 106, 98, 105, 103, 110, 105, 104,
+             100, 96, 108, 103, 104, 114, 114, 113, 108, 106, 99)
> ansari.test(ramsay, jung.parekh)
Warning in ansari.test.default(ramsay, jung.parekh) :
  cannot compute exact p-value with ties

	Ansari-Bradley test

data:  ramsay and jung.parekh
AB = 185.5, p-value = 0.1815
alternative hypothesis: true ratio of scales is not equal to 1

> 
> ansari.test(rnorm(10), rnorm(10, 0, 2), conf.int = TRUE)

	Ansari-Bradley test

data:  rnorm(10) and rnorm(10, 0, 2)
AB = 69, p-value = 0.03831
alternative hypothesis: true ratio of scales is not equal to 1
95 percent confidence interval:
 0.1852324 0.9712857
sample estimates:
ratio of scales 
      0.4007458 

> 
> ## try more points - failed in 2.4.1
> ansari.test(rnorm(100), rnorm(100, 0, 2), conf.int = TRUE)

	Ansari-Bradley test

data:  rnorm(100) and rnorm(100, 0, 2)
AB = 6180, p-value = 3.347e-08
alternative hypothesis: true ratio of scales is not equal to 1
95 percent confidence interval:
 0.3330596 0.5693532
sample estimates:
ratio of scales 
      0.4346784 

> 
> 
> 
> cleanEx()
> nameEx("aov")
> ### * aov
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: aov
> ### Title: Fit an Analysis of Variance Model
> ### Aliases: aov print.aov print.aovlist Error
> ### Keywords: models regression
> 
> ### ** Examples
> 
> ## From Venables and Ripley (2002) p.165.
> 
> ## Set orthogonal contrasts.
> op <- options(contrasts = c("contr.helmert", "contr.poly"))
> ( npk.aov <- aov(yield ~ block + N*P*K, npk) )
Call:
   aov(formula = yield ~ block + N * P * K, data = npk)

Terms:
                   block        N        P        K      N:P      N:K      P:K
Sum of Squares  343.2950 189.2817   8.4017  95.2017  21.2817  33.1350   0.4817
Deg. of Freedom        5        1        1        1        1        1        1
                Residuals
Sum of Squares   185.2867
Deg. of Freedom        12

Residual standard error: 3.929447
1 out of 13 effects not estimable
Estimated effects are balanced
> coefficients(npk.aov)
(Intercept)      block1      block2      block3      block4      block5 
 54.8750000   1.7125000   1.6791667  -1.8229167  -1.0137500   0.2950000 
         N1          P1          K1       N1:P1       N1:K1       P1:K1 
  2.8083333  -0.5916667  -1.9916667  -0.9416667  -1.1750000   0.1416667 
> 
> ## to show the effects of re-ordering terms contrast the two fits
> aov(yield ~ block + N * P + K, npk)
Call:
   aov(formula = yield ~ block + N * P + K, data = npk)

Terms:
                   block        N        P        K      N:P Residuals
Sum of Squares  343.2950 189.2817   8.4017  95.2017  21.2817  218.9033
Deg. of Freedom        5        1        1        1        1        14

Residual standard error: 3.954232
Estimated effects are balanced
> aov(terms(yield ~ block + N * P + K, keep.order = TRUE), npk)
Call:
   aov(formula = terms(yield ~ block + N * P + K, keep.order = TRUE), 
    data = npk)

Terms:
                   block        N        P      N:P        K Residuals
Sum of Squares  343.2950 189.2817   8.4017  21.2817  95.2017  218.9033
Deg. of Freedom        5        1        1        1        1        14

Residual standard error: 3.954232
Estimated effects are balanced
> 
> 
> ## as a test, not particularly sensible statistically
> npk.aovE <- aov(yield ~  N*P*K + Error(block), npk)
> npk.aovE

Call:
aov(formula = yield ~ N * P * K + Error(block), data = npk)

Grand Mean: 54.875

Stratum 1: block

Terms:
                    N:P:K Residuals
Sum of Squares   37.00167 306.29333
Deg. of Freedom         1         4

Residual standard error: 8.750619
Estimated effects are balanced

Stratum 2: Within

Terms:
                        N         P         K       N:P       N:K       P:K
Sum of Squares  189.28167   8.40167  95.20167  21.28167  33.13500   0.48167
Deg. of Freedom         1         1         1         1         1         1
                Residuals
Sum of Squares  185.28667
Deg. of Freedom        12

Residual standard error: 3.929447
Estimated effects are balanced
> ## IGNORE_RDIFF_BEGIN
> summary(npk.aovE)

Error: block
          Df Sum Sq Mean Sq F value Pr(>F)
N:P:K      1   37.0   37.00   0.483  0.525
Residuals  4  306.3   76.57               

Error: Within
          Df Sum Sq Mean Sq F value  Pr(>F)   
N          1 189.28  189.28  12.259 0.00437 **
P          1   8.40    8.40   0.544 0.47490   
K          1  95.20   95.20   6.166 0.02880 * 
N:P        1  21.28   21.28   1.378 0.26317   
N:K        1  33.14   33.14   2.146 0.16865   
P:K        1   0.48    0.48   0.031 0.86275   
Residuals 12 185.29   15.44                   
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
> ## IGNORE_RDIFF_END
> options(op)  # reset to previous
> 
> 
> 
> base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
> cleanEx()
> nameEx("approxfun")
> ### * approxfun
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: approxfun
> ### Title: Interpolation Functions
> ### Aliases: approx approxfun
> ### Keywords: arith dplot
> 
> ### ** Examples
> 
> require(graphics)
> 
> x <- 1:10
> y <- rnorm(10)
> par(mfrow = c(2,1))
> plot(x, y, main = "approx(.) and approxfun(.)")
> points(approx(x, y), col = 2, pch = "*")
> points(approx(x, y, method = "constant"), col = 4, pch = "*")
> 
> f <- approxfun(x, y)
> curve(f(x), 0, 11, col = "green2")
> points(x, y)
> is.function(fc <- approxfun(x, y, method = "const")) # TRUE
[1] TRUE
> curve(fc(x), 0, 10, col = "darkblue", add = TRUE)
> ## different extrapolation on left and right side :
> plot(approxfun(x, y, rule = 2:1), 0, 11,
+      col = "tomato", add = TRUE, lty = 3, lwd = 2)
> 
> ### Treatment of 'NA's -- are kept if  na.rm=FALSE :
> 
> xn <- 1:4
> yn <- c(1,NA,3:4)
> xout <- (1:9)/2
> ## Default behavior (na.rm = TRUE): NA's omitted; extrapolation gives NA
> data.frame(approx(xn,yn, xout))
    x   y
1 0.5  NA
2 1.0 1.0
3 1.5 1.5
4 2.0 2.0
5 2.5 2.5
6 3.0 3.0
7 3.5 3.5
8 4.0 4.0
9 4.5  NA
> data.frame(approx(xn,yn, xout, rule = 2))# -> *constant* extrapolation
    x   y
1 0.5 1.0
2 1.0 1.0
3 1.5 1.5
4 2.0 2.0
5 2.5 2.5
6 3.0 3.0
7 3.5 3.5
8 4.0 4.0
9 4.5 4.0
> ## New (2019-2020)  na.rm = FALSE: NA's are "kept"
> data.frame(approx(xn,yn, xout, na.rm=FALSE, rule = 2))
    x   y
1 0.5 1.0
2 1.0 1.0
3 1.5  NA
4 2.0  NA
5 2.5  NA
6 3.0 3.0
7 3.5 3.5
8 4.0 4.0
9 4.5 4.0
> data.frame(approx(xn,yn, xout, na.rm=FALSE, rule = 2, method="constant"))
    x  y
1 0.5  1
2 1.0  1
3 1.5  1
4 2.0 NA
5 2.5 NA
6 3.0  3
7 3.5  3
8 4.0  4
9 4.5  4
> 
> ## NA's in x[] are not allowed:
> stopifnot(inherits( try( approx(yn,yn, na.rm=FALSE) ), "try-error"))
Error in approx(yn, yn, na.rm = FALSE) : 
  approx(x,y, .., na.rm=FALSE): NA values in x are not allowed
> 
> ## Give a nice overview of all possibilities  rule * method * na.rm :
> ##             -----------------------------  ====   ======   =====
> ## extrapolations "N":= NA;   "C":= Constant :
> rules <- list(N=1, C=2, NC=1:2, CN=2:1)
> methods <- c("constant","linear")
> ry <- sapply(rules, function(R) {
+        sapply(methods, function(M)
+         sapply(setNames(,c(TRUE,FALSE)), function(na.)
+                  approx(xn, yn, xout=xout, method=M, rule=R, na.rm=na.)$y),
+         simplify="array")
+    }, simplify="array")
> names(dimnames(ry)) <- c("x = ", "na.rm", "method", "rule")
> dimnames(ry)[[1]] <- format(xout)
> ftable(aperm(ry, 4:1)) # --> (4 * 2 * 2) x length(xout)  =  16 x 9 matrix
                    x =  0.5 1.0 1.5 2.0 2.5 3.0 3.5 4.0 4.5
rule method   na.rm                                         
N    constant TRUE        NA 1.0 1.0 1.0 1.0 3.0 3.0 4.0  NA
              FALSE       NA 1.0 1.0  NA  NA 3.0 3.0 4.0  NA
     linear   TRUE        NA 1.0 1.5 2.0 2.5 3.0 3.5 4.0  NA
              FALSE       NA 1.0  NA  NA  NA 3.0 3.5 4.0  NA
C    constant TRUE       1.0 1.0 1.0 1.0 1.0 3.0 3.0 4.0 4.0
              FALSE      1.0 1.0 1.0  NA  NA 3.0 3.0 4.0 4.0
     linear   TRUE       1.0 1.0 1.5 2.0 2.5 3.0 3.5 4.0 4.0
              FALSE      1.0 1.0  NA  NA  NA 3.0 3.5 4.0 4.0
NC   constant TRUE        NA 1.0 1.0 1.0 1.0 3.0 3.0 4.0 4.0
              FALSE       NA 1.0 1.0  NA  NA 3.0 3.0 4.0 4.0
     linear   TRUE        NA 1.0 1.5 2.0 2.5 3.0 3.5 4.0 4.0
              FALSE       NA 1.0  NA  NA  NA 3.0 3.5 4.0 4.0
CN   constant TRUE       1.0 1.0 1.0 1.0 1.0 3.0 3.0 4.0  NA
              FALSE      1.0 1.0 1.0  NA  NA 3.0 3.0 4.0  NA
     linear   TRUE       1.0 1.0 1.5 2.0 2.5 3.0 3.5 4.0  NA
              FALSE      1.0 1.0  NA  NA  NA 3.0 3.5 4.0  NA
> ## Don't show: 
> stopifnot(exprs = {
+  identical(unname(ry),
+    array(c(NA, 1, 1,   1, 1, 3, 3, 4, NA,      NA, 1,  1, NA, NA, 3, 3, 4, NA,
+            NA, 1, 1.5, 2, 2.5, 3, 3.5, 4, NA,  NA, 1, NA, NA, NA, 3, 3.5, 4, NA,
+             1, 1, 1,   1, 1, 3, 3, 4, 4,        1, 1,  1, NA, NA, 3, 3, 4, 4,
+             1, 1, 1.5, 2, 2.5, 3, 3.5, 4, 4,    1, 1, NA, NA, NA, 3, 3.5, 4, 4,
+            NA, 1, 1,   1, 1, 3, 3, 4, 4,       NA, 1,  1, NA, NA, 3, 3, 4, 4,
+            NA, 1, 1.5, 2, 2.5, 3, 3.5, 4, 4,   NA, 1, NA, NA, NA, 3, 3.5, 4, 4,
+             1, 1, 1,   1, 1, 3, 3, 4, NA,       1, 1,  1, NA, NA, 3, 3, 4, NA,
+             1, 1, 1.5, 2, 2.5, 3, 3.5, 4, NA,   1, 1, NA, NA, NA, 3, 3.5, 4, NA),
+          dim = c(9L, 2L, 2L, 4L)))
+  identical(approxfun(xn,yn, method="constant", rule=2, na.rm=FALSE)(xout),
+             as.vector(ry[,"FALSE", "constant","C"]))
+  identical(approxfun(xn,yn, method="linear", rule=2:1, na.rm=FALSE)(xout),
+             as.vector(ry[,"FALSE", "linear", "CN"]))
+ })
> ## End(Don't show)
> 
> ## Show treatment of 'ties' :
> 
> x <- c(2,2:4,4,4,5,5,7,7,7)
> y <- c(1:6, 5:4, 3:1)
> (amy <- approx(x, y, xout = x)$y) # warning, can be avoided by specifying 'ties=':
Warning in regularize.values(x, y, ties, missing(ties), na.rm = na.rm) :
  collapsing to unique 'x' values
 [1] 1.5 1.5 3.0 5.0 5.0 5.0 4.5 4.5 2.0 2.0 2.0
> op <- options(warn=2) # warnings would be error
> stopifnot(identical(amy, approx(x, y, xout = x, ties=mean)$y))
> (ay <- approx(x, y, xout = x, ties = "ordered")$y)
 [1] 2 2 3 6 6 6 4 4 1 1 1
> stopifnot(amy == c(1.5,1.5, 3, 5,5,5, 4.5,4.5, 2,2,2),
+           ay  == c(2, 2,    3, 6,6,6, 4, 4,    1,1,1))
> approx(x, y, xout = x, ties = min)$y
 [1] 1 1 3 4 4 4 4 4 1 1 1
> approx(x, y, xout = x, ties = max)$y
 [1] 2 2 3 6 6 6 5 5 3 3 3
> options(op) # revert 'warn'ing level
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("ar")
> ### * ar
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ar
> ### Title: Fit Autoregressive Models to Time Series
> ### Aliases: ar ar.burg ar.burg.default ar.burg.mts ar.yw ar.yw.default
> ###   ar.yw.mts ar.mle print.ar predict.ar
> ### Keywords: ts
> 
> ### ** Examples
> 
> ar(lh)

Call:
ar(x = lh)

Coefficients:
      1        2        3  
 0.6534  -0.0636  -0.2269  

Order selected 3  sigma^2 estimated as  0.1959
> ar(lh, method = "burg")

Call:
ar(x = lh, method = "burg")

Coefficients:
      1        2        3  
 0.6588  -0.0608  -0.2234  

Order selected 3  sigma^2 estimated as  0.1786
> ar(lh, method = "ols")

Call:
ar(x = lh, method = "ols")

Coefficients:
    1  
0.586  

Intercept: 0.006234 (0.06551) 

Order selected 1  sigma^2 estimated as  0.2016
> ar(lh, FALSE, 4) # fit ar(4)

Call:
ar(x = lh, aic = FALSE, order.max = 4)

Coefficients:
      1        2        3        4  
 0.6767  -0.0571  -0.2941   0.1028  

Order selected 4  sigma^2 estimated as  0.1983
> 
> (sunspot.ar <- ar(sunspot.year))

Call:
ar(x = sunspot.year)

Coefficients:
      1        2        3        4        5        6        7        8  
 1.1305  -0.3524  -0.1745   0.1403  -0.1358   0.0963  -0.0556   0.0076  
      9  
 0.1941  

Order selected 9  sigma^2 estimated as  267.5
> predict(sunspot.ar, n.ahead = 25)
$pred
Time Series:
Start = 1989 
End = 2013 
Frequency = 1 
 [1] 135.25933 148.09051 133.98476 106.61344  71.21921  40.84057  18.70100
 [8]  11.52416  27.24208  56.99888  87.86705 107.62926 111.05437  98.05484
[15]  74.84085  48.80128  27.65441  18.15075  23.15355  40.04723  61.95906
[22]  80.79092  90.11420  87.44131  74.42284

$se
Time Series:
Start = 1989 
End = 2013 
Frequency = 1 
 [1] 16.35519 24.68467 28.95653 29.97401 30.07714 30.15629 30.35971 30.58793
 [9] 30.71100 30.74276 31.42565 32.96467 34.48910 35.33601 35.51890 35.52034
[17] 35.65505 35.90628 36.07084 36.08139 36.16818 36.56324 37.16527 37.64820
[25] 37.83954

> ## try the other methods too
> 
> ar(ts.union(BJsales, BJsales.lead))

Call:
ar(x = ts.union(BJsales, BJsales.lead))

$ar
, , 1

             BJsales BJsales.lead
BJsales       0.9499       0.8222
BJsales.lead  0.0276       0.4970

, , 2

              BJsales BJsales.lead
BJsales       0.02041       -1.133
BJsales.lead -0.02193        0.294

, , 3

               BJsales BJsales.lead
BJsales      -0.186490       3.9415
BJsales.lead -0.002946       0.1264


$var.pred
             BJsales BJsales.lead
BJsales      13.9431       0.7733
BJsales.lead  0.7733       0.1231

> ## Burg is quite different here, as is OLS (see ar.ols)
> ar(ts.union(BJsales, BJsales.lead), method = "burg")

Call:
ar(x = ts.union(BJsales, BJsales.lead), method = "burg")

$ar
, , 1

             BJsales BJsales.lead
BJsales      1.21197      0.07312
BJsales.lead 0.07411      0.45684

, , 2

              BJsales BJsales.lead
BJsales      -0.26022      -0.1120
BJsales.lead -0.06904       0.3111

, , 3

              BJsales BJsales.lead
BJsales      -0.01754      3.93591
BJsales.lead  0.01792      0.09632

, , 4

              BJsales BJsales.lead
BJsales      -0.07746     -1.33836
BJsales.lead -0.01158     -0.09118


$var.pred
             BJsales BJsales.lead
BJsales      0.38426      0.01315
BJsales.lead 0.01315      0.07657

> 
> 
> 
> cleanEx()
> nameEx("ar.ols")
> ### * ar.ols
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ar.ols
> ### Title: Fit Autoregressive Models to Time Series by OLS
> ### Aliases: ar.ols
> ### Keywords: ts
> 
> ### ** Examples
> 
> ar(lh, method = "burg")

Call:
ar(x = lh, method = "burg")

Coefficients:
      1        2        3  
 0.6588  -0.0608  -0.2234  

Order selected 3  sigma^2 estimated as  0.1786
> ar.ols(lh)

Call:
ar.ols(x = lh)

Coefficients:
    1  
0.586  

Intercept: 0.006234 (0.06551) 

Order selected 1  sigma^2 estimated as  0.2016
> ar.ols(lh, FALSE, 4) # fit ar(4)

Call:
ar.ols(x = lh, aic = FALSE, order.max = 4)

Coefficients:
      1        2        3        4  
 0.6761  -0.0571  -0.3001   0.0967  

Intercept: 0.0004346 (0.06642) 

Order selected 4  sigma^2 estimated as  0.1924
> 
> ar.ols(ts.union(BJsales, BJsales.lead))

Call:
ar.ols(x = ts.union(BJsales, BJsales.lead))

$ar
, , 1

             BJsales BJsales.lead
BJsales      0.40408     -0.05144
BJsales.lead 0.07348      0.54524

, , 2

             BJsales BJsales.lead
BJsales       0.2367      0.05899
BJsales.lead -0.1224      0.28690

, , 3

             BJsales BJsales.lead
BJsales      0.09673       4.7413
BJsales.lead 0.10469       0.0701

, , 4

              BJsales BJsales.lead
BJsales      0.048758       1.5671
BJsales.lead 0.003482      -0.1838

, , 5

              BJsales BJsales.lead
BJsales       0.23307      -0.1574
BJsales.lead -0.02707       0.2623

, , 6

              BJsales BJsales.lead
BJsales       0.07494      -0.4313
BJsales.lead -0.08729      -0.2166

, , 7

              BJsales BJsales.lead
BJsales      -0.09946      -0.6233
BJsales.lead  0.27123      -0.2584

, , 8

              BJsales BJsales.lead
BJsales       0.06725     -1.36469
BJsales.lead -0.21501      0.06115

, , 9

              BJsales BJsales.lead
BJsales      -0.11531       -1.464
BJsales.lead  0.03536        0.270

, , 10

               BJsales BJsales.lead
BJsales      -0.002037      -0.6472
BJsales.lead  0.001284      -1.0667

, , 11

              BJsales BJsales.lead
BJsales      0.004065      -0.7009
BJsales.lead 0.002098       0.4890


$x.intercept
     BJsales BJsales.lead 
     0.19630     -0.07022 

$var.pred
                BJsales BJsales.lead
BJsales       0.0400996   -0.0009311
BJsales.lead -0.0009311    0.0682137

> 
> x <- diff(log(EuStockMarkets))
> ar.ols(x, order.max = 6, demean = FALSE, intercept = TRUE)

Call:
ar.ols(x = x, order.max = 6, demean = FALSE, intercept = TRUE)

$ar
, , 1

           DAX       SMI       CAC    FTSE
DAX   0.004560 -0.095781  0.039975 0.04856
SMI  -0.009204 -0.007142  0.037758 0.06826
CAC  -0.026624 -0.113688  0.063807 0.09154
FTSE -0.010299 -0.089246 -0.003195 0.16409


$x.intercept
      DAX       SMI       CAC      FTSE 
0.0006941 0.0007813 0.0004866 0.0004388 

$var.pred
           DAX       SMI       CAC      FTSE
DAX  1.056e-04 6.683e-05 8.274e-05 5.192e-05
SMI  6.683e-05 8.496e-05 6.252e-05 4.254e-05
CAC  8.274e-05 6.252e-05 1.207e-04 5.615e-05
FTSE 5.192e-05 4.254e-05 5.615e-05 6.224e-05

> 
> 
> 
> cleanEx()
> nameEx("arima")
> ### * arima
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: arima
> ### Title: ARIMA Modelling of Time Series
> ### Aliases: arima
> ### Keywords: ts
> 
> ### ** Examples
> 
> arima(lh, order = c(1,0,0))

Call:
arima(x = lh, order = c(1, 0, 0))

Coefficients:
         ar1  intercept
      0.5739     2.4133
s.e.  0.1161     0.1466

sigma^2 estimated as 0.1975:  log likelihood = -29.38,  aic = 64.76
> arima(lh, order = c(3,0,0))

Call:
arima(x = lh, order = c(3, 0, 0))

Coefficients:
         ar1      ar2      ar3  intercept
      0.6448  -0.0634  -0.2198     2.3931
s.e.  0.1394   0.1668   0.1421     0.0963

sigma^2 estimated as 0.1787:  log likelihood = -27.09,  aic = 64.18
> arima(lh, order = c(1,0,1))

Call:
arima(x = lh, order = c(1, 0, 1))

Coefficients:
         ar1     ma1  intercept
      0.4522  0.1982     2.4101
s.e.  0.1769  0.1705     0.1358

sigma^2 estimated as 0.1923:  log likelihood = -28.76,  aic = 65.52
> 
> arima(lh, order = c(3,0,0), method = "CSS")

Call:
arima(x = lh, order = c(3, 0, 0), method = "CSS")

Coefficients:
         ar1      ar2      ar3  intercept
      0.6578  -0.0658  -0.2348     2.3918
s.e.  0.1414   0.1702   0.1473     0.0983

sigma^2 estimated as 0.1905:  part log likelihood = -28.31
> 
> arima(USAccDeaths, order = c(0,1,1), seasonal = list(order = c(0,1,1)))

Call:
arima(x = USAccDeaths, order = c(0, 1, 1), seasonal = list(order = c(0, 1, 1)))

Coefficients:
          ma1     sma1
      -0.4303  -0.5528
s.e.   0.1228   0.1784

sigma^2 estimated as 99347:  log likelihood = -425.44,  aic = 856.88
> arima(USAccDeaths, order = c(0,1,1), seasonal = list(order = c(0,1,1)),
+       method = "CSS") # drops first 13 observations.

Call:
arima(x = USAccDeaths, order = c(0, 1, 1), seasonal = list(order = c(0, 1, 1)), 
    method = "CSS")

Coefficients:
          ma1     sma1
      -0.3732  -0.4549
s.e.   0.1366   0.1436

sigma^2 estimated as 110330:  part log likelihood = -426.25
> # for a model with as few years as this, we want full ML
> 
> arima(LakeHuron, order = c(2,0,0), xreg = time(LakeHuron) - 1920)

Call:
arima(x = LakeHuron, order = c(2, 0, 0), xreg = time(LakeHuron) - 1920)

Coefficients:
         ar1      ar2  intercept  time(LakeHuron) - 1920
      1.0048  -0.2913   579.0993                 -0.0216
s.e.  0.0976   0.1004     0.2370                  0.0081

sigma^2 estimated as 0.4566:  log likelihood = -101.2,  aic = 212.4
> 
> ## presidents contains NAs
> ## graphs in example(acf) suggest order 1 or 3
> require(graphics)
> (fit1 <- arima(presidents, c(1, 0, 0)))

Call:
arima(x = presidents, order = c(1, 0, 0))

Coefficients:
         ar1  intercept
      0.8242    56.1505
s.e.  0.0555     4.6434

sigma^2 estimated as 85.47:  log likelihood = -416.89,  aic = 839.78
> nobs(fit1)
[1] 114
> tsdiag(fit1)
> (fit3 <- arima(presidents, c(3, 0, 0)))  # smaller AIC

Call:
arima(x = presidents, order = c(3, 0, 0))

Coefficients:
         ar1     ar2      ar3  intercept
      0.7496  0.2523  -0.1890    56.2223
s.e.  0.0936  0.1140   0.0946     4.2845

sigma^2 estimated as 81.12:  log likelihood = -414.08,  aic = 838.16
> tsdiag(fit3)
> BIC(fit1, fit3)
     df      BIC
fit1  3 847.9931
fit3  5 851.8449
> ## compare a whole set of models; BIC() would choose the smallest
> AIC(fit1, arima(presidents, c(2,0,0)),
+           arima(presidents, c(2,0,1)), # <- chosen (barely) by AIC
+     fit3, arima(presidents, c(3,0,1)))
                              df      AIC
fit1                           3 839.7845
arima(presidents, c(2, 0, 0))  4 840.0458
arima(presidents, c(2, 0, 1))  5 838.1272
fit3                           5 838.1639
arima(presidents, c(3, 0, 1))  6 838.8124
> 
> ## An example of using the  'fixed'  argument:
> ## Note that the period of the seasonal component is taken to be
> ## frequency(presidents), i.e. 4.
> (fitSfx <- arima(presidents, order=c(2,0,1), seasonal=c(1,0,0),
+                  fixed=c(NA, NA, 0.5, -0.1, 50), transform.pars=FALSE))

Call:
arima(x = presidents, order = c(2, 0, 1), seasonal = c(1, 0, 0), transform.pars = FALSE, 
    fixed = c(NA, NA, 0.5, -0.1, 50))

Coefficients:
         ar1     ar2  ma1  sar1  intercept
      0.2047  0.6269  0.5  -0.1         50
s.e.  0.0734  0.0747  0.0   0.0          0

sigma^2 estimated as 84.01:  log likelihood = -416.07,  aic = 838.14
> ## The partly-fixed & smaller model seems better (as we "knew too much"):
> AIC(fitSfx, arima(presidents, order=c(2,0,1), seasonal=c(1,0,0)))
                                                             df      AIC
fitSfx                                                        3 838.1406
arima(presidents, order = c(2, 0, 1), seasonal = c(1, 0, 0))  6 839.7095
> 
> ## An example of ARIMA forecasting:
> predict(fit3, 3)
$pred
         Qtr1     Qtr2     Qtr3
1975 29.84194 34.41014 39.30815

$se
         Qtr1     Qtr2     Qtr3
1975  9.00655 11.25606 13.43389

> 
> 
> 
> cleanEx()
> nameEx("arima.sim")
> ### * arima.sim
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: arima.sim
> ### Title: Simulate from an ARIMA Model
> ### Aliases: arima.sim
> ### Keywords: ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> arima.sim(n = 63, list(ar = c(0.8897, -0.4858), ma = c(-0.2279, 0.2488)),
+           sd = sqrt(0.1796))
Time Series:
Start = 1 
End = 63 
Frequency = 1 
 [1]  0.55638574  0.24800500 -0.81744783 -0.38508849 -0.23890454 -0.02072714
 [7] -0.51654590 -0.52651638 -0.14927781  0.60798558  0.48272646  0.45160066
[13]  0.09619832 -0.67131480 -0.69254708 -0.56224691 -0.19460368  0.53033791
[19]  0.77731125  0.40648873 -0.02697856  0.08101569  0.22706682 -0.10950180
[25] -0.38234797 -0.13676254  0.27995530  0.23211869  0.53580489  0.43571147
[31] -0.07756004 -0.03502285 -0.56957457  0.26261214  1.09213953  0.64829971
[37] -0.15198589 -0.14659775 -0.27894630  0.91394089  0.68582187  0.71550492
[43]  0.24452551 -0.37501019 -0.29768875 -0.94420587  0.11988146  0.29844068
[49]  1.26774646  0.99077203  0.14790214  0.02779843 -0.57682386 -0.90337297
[55] -0.37740926 -0.24511724  0.03927715  0.13868087 -0.15259447 -0.37935616
[61] -0.32790595  0.34491331 -0.30754547
> # mildly long-tailed
> arima.sim(n = 63, list(ar = c(0.8897, -0.4858), ma = c(-0.2279, 0.2488)),
+           rand.gen = function(n, ...) sqrt(0.1796) * rt(n, df = 5))
Time Series:
Start = 1 
End = 63 
Frequency = 1 
 [1] -0.08101433 -0.37596592 -1.05656365 -0.99217317 -0.15199924 -0.06140144
 [7] -0.55852200 -0.54700937 -0.72098523 -0.98045523 -0.80880380 -0.61217798
[13] -0.66268921 -0.29302949 -0.83022714 -0.08803618 -0.37932440  0.10532621
[19]  0.08033289 -0.29269083 -0.69193397  0.81677306 -0.25402288 -0.08812258
[25] -0.34117754  0.29026870 -0.54848673 -0.44974248 -0.34110521 -0.17826307
[31] -0.35396760  0.98465366  0.21136827  0.05042017 -0.02400316 -0.42642295
[37] -0.61906692  1.92955621 -0.36050863 -0.68488280  0.10141464  0.64328982
[43]  0.31906603  0.17275054 -0.13570368 -0.13451166 -0.11717037  0.02330814
[49]  0.29918521  0.05938999 -0.20355761 -0.02439309 -1.14548572 -0.94045141
[55]  0.44845239  1.76898773  1.78579981  1.16734413  0.33858833 -0.41153063
[61] -0.31037109 -0.31929663  0.17496536
> 
> # An ARIMA simulation
> ts.sim <- arima.sim(list(order = c(1,1,0), ar = 0.7), n = 200)
> ts.plot(ts.sim)
> 
> 
> 
> cleanEx()
> nameEx("arima0")
> ### * arima0
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: arima0
> ### Title: ARIMA Modelling of Time Series - Preliminary Version
> ### Aliases: arima0 print.arima0 predict.arima0
> ### Keywords: ts
> 
> ### ** Examples
> 
> ## Not run: arima0(lh, order = c(1,0,0))
> arima0(lh, order = c(3,0,0))

Call:
arima0(x = lh, order = c(3, 0, 0))

Coefficients:
         ar1      ar2      ar3  intercept
      0.6448  -0.0634  -0.2198     2.3931
s.e.  0.1394   0.1668   0.1421     0.0963

sigma^2 estimated as 0.1787:  log likelihood = -27.09,  aic = 64.18
> arima0(lh, order = c(1,0,1))

Call:
arima0(x = lh, order = c(1, 0, 1))

Coefficients:
         ar1     ma1  intercept
      0.4521  0.1983     2.4101
s.e.  0.1357  0.1777     0.1357

sigma^2 estimated as 0.1923:  log likelihood = -28.76,  aic = 65.52
> predict(arima0(lh, order = c(3,0,0)), n.ahead = 12)
$pred
Time Series:
Start = 49 
End = 60 
Frequency = 1 
 [1] 2.460173 2.270829 2.198597 2.260696 2.346933 2.414479 2.438918 2.431440
 [9] 2.410223 2.391645 2.382653 2.382697

$se
Time Series:
Start = 49 
End = 60 
Frequency = 1 
 [1] 0.4226823 0.5029332 0.5245256 0.5247161 0.5305499 0.5369159 0.5388045
 [8] 0.5388448 0.5391043 0.5395174 0.5396991 0.5397140

> 
> arima0(lh, order = c(3,0,0), method = "CSS")

Call:
arima0(x = lh, order = c(3, 0, 0), method = "CSS")

Coefficients:
         ar1      ar2      ar3  intercept
      0.6580  -0.0660  -0.2339     2.3999
s.e.  0.1414   0.1702   0.1469     0.0981

sigma^2 estimated as 0.1905:  part log likelihood = -28.31
> 
> # for a model with as few years as this, we want full ML
> (fit <- arima0(USAccDeaths, order = c(0,1,1),
+                seasonal = list(order=c(0,1,1)), delta = -1))

Call:
arima0(x = USAccDeaths, order = c(0, 1, 1), seasonal = list(order = c(0, 1, 
    1)), delta = -1)

Coefficients:
          ma1     sma1
      -0.4304  -0.5526
s.e.   0.1228   0.1785

sigma^2 estimated as 99355:  log likelihood = -425.44,  aic = 856.88
> predict(fit, n.ahead = 6)
$pred
          Jan      Feb      Mar      Apr      May      Jun
1979 8336.028 7531.760 8314.593 8616.864 9488.916 9859.727

$se
          Jan      Feb      Mar      Apr      May      Jun
1979 315.4607 362.9949 404.9878 443.0180 478.0322 510.6511

> 
> arima0(LakeHuron, order = c(2,0,0), xreg = time(LakeHuron)-1920)

Call:
arima0(x = LakeHuron, order = c(2, 0, 0), xreg = time(LakeHuron) - 1920)

Coefficients:
         ar1      ar2  intercept     xreg
      1.0048  -0.2913   579.0985  -0.0216
s.e.  0.0976   0.1004     0.2370   0.0081

sigma^2 estimated as 0.4566:  log likelihood = -101.2,  aic = 212.4
> ## Not run: 
> ##D ## presidents contains NAs
> ##D ## graphs in example(acf) suggest order 1 or 3
> ##D (fit1 <- arima0(presidents, c(1, 0, 0), delta = -1))  # avoid warning
> ##D tsdiag(fit1)
> ##D (fit3 <- arima0(presidents, c(3, 0, 0), delta = -1))  # smaller AIC
> ##D tsdiag(fit3)
> ## End(Not run)
> 
> 
> 
> cleanEx()
> nameEx("as.hclust")
> ### * as.hclust
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: as.hclust
> ### Title: Convert Objects to Class hclust
> ### Aliases: as.hclust as.hclust.default as.hclust.twins
> ### Keywords: multivariate cluster
> 
> ### ** Examples
> 
> x <- matrix(rnorm(30), ncol = 3)
> hc <- hclust(dist(x), method = "complete")
> 
> 
> 
> 
> cleanEx()
> nameEx("asOneSidedFormula")
> ### * asOneSidedFormula
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: asOneSidedFormula
> ### Title: Convert to One-Sided Formula
> ### Aliases: asOneSidedFormula
> ### Keywords: models
> 
> ### ** Examples
> 
> (form <- asOneSidedFormula("age"))
~age
> stopifnot(exprs = {
+     identical(form, asOneSidedFormula(form))
+     identical(form, asOneSidedFormula(as.name("age")))
+     identical(form, asOneSidedFormula(expression(age)))
+ })
> asOneSidedFormula(quote(log(age)))
~log(age)
> asOneSidedFormula(1)
~1
> 
> 
> 
> cleanEx()
> nameEx("ave")
> ### * ave
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ave
> ### Title: Group Averages Over Level Combinations of Factors
> ### Aliases: ave
> ### Keywords: univar
> 
> ### ** Examples
> 
> require(graphics)
> 
> ave(1:3)  # no grouping -> grand mean
[1] 2 2 2
> 
> attach(warpbreaks)
> ave(breaks, wool)
 [1] 31.03704 31.03704 31.03704 31.03704 31.03704 31.03704 31.03704 31.03704
 [9] 31.03704 31.03704 31.03704 31.03704 31.03704 31.03704 31.03704 31.03704
[17] 31.03704 31.03704 31.03704 31.03704 31.03704 31.03704 31.03704 31.03704
[25] 31.03704 31.03704 31.03704 25.25926 25.25926 25.25926 25.25926 25.25926
[33] 25.25926 25.25926 25.25926 25.25926 25.25926 25.25926 25.25926 25.25926
[41] 25.25926 25.25926 25.25926 25.25926 25.25926 25.25926 25.25926 25.25926
[49] 25.25926 25.25926 25.25926 25.25926 25.25926 25.25926
> ave(breaks, tension)
 [1] 36.38889 36.38889 36.38889 36.38889 36.38889 36.38889 36.38889 36.38889
 [9] 36.38889 26.38889 26.38889 26.38889 26.38889 26.38889 26.38889 26.38889
[17] 26.38889 26.38889 21.66667 21.66667 21.66667 21.66667 21.66667 21.66667
[25] 21.66667 21.66667 21.66667 36.38889 36.38889 36.38889 36.38889 36.38889
[33] 36.38889 36.38889 36.38889 36.38889 26.38889 26.38889 26.38889 26.38889
[41] 26.38889 26.38889 26.38889 26.38889 26.38889 21.66667 21.66667 21.66667
[49] 21.66667 21.66667 21.66667 21.66667 21.66667 21.66667
> ave(breaks, tension, FUN = function(x) mean(x, trim = 0.1))
 [1] 35.6875 35.6875 35.6875 35.6875 35.6875 35.6875 35.6875 35.6875 35.6875
[10] 26.3125 26.3125 26.3125 26.3125 26.3125 26.3125 26.3125 26.3125 26.3125
[19] 21.0625 21.0625 21.0625 21.0625 21.0625 21.0625 21.0625 21.0625 21.0625
[28] 35.6875 35.6875 35.6875 35.6875 35.6875 35.6875 35.6875 35.6875 35.6875
[37] 26.3125 26.3125 26.3125 26.3125 26.3125 26.3125 26.3125 26.3125 26.3125
[46] 21.0625 21.0625 21.0625 21.0625 21.0625 21.0625 21.0625 21.0625 21.0625
> plot(breaks, main =
+      "ave( Warpbreaks )  for   wool  x  tension  combinations")
> lines(ave(breaks, wool, tension              ), type = "s", col = "blue")
> lines(ave(breaks, wool, tension, FUN = median), type = "s", col = "green")
> legend(40, 70, c("mean", "median"), lty = 1,
+       col = c("blue","green"), bg = "gray90")
> detach()
> 
> 
> 
> cleanEx()
> nameEx("bandwidth")
> ### * bandwidth
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: bandwidth
> ### Title: Bandwidth Selectors for Kernel Density Estimation
> ### Aliases: bw.nrd0 bw.nrd bw.ucv bw.bcv bw.SJ
> ### Keywords: distribution smooth
> 
> ### ** Examples
> 
> require(graphics)
> 
> plot(density(precip, n = 1000))
> rug(precip)
> lines(density(precip, bw = "nrd"), col = 2)
> lines(density(precip, bw = "ucv"), col = 3)
> lines(density(precip, bw = "bcv"), col = 4)
Warning in bw.bcv(x) : minimum occurred at one end of the range
> lines(density(precip, bw = "SJ-ste"), col = 5)
> lines(density(precip, bw = "SJ-dpi"), col = 6)
> legend(55, 0.035,
+        legend = c("nrd0", "nrd", "ucv", "bcv", "SJ-ste", "SJ-dpi"),
+        col = 1:6, lty = 1)
> 
> 
> 
> cleanEx()
> nameEx("bartlett.test")
> ### * bartlett.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: bartlett.test
> ### Title: Bartlett Test of Homogeneity of Variances
> ### Aliases: bartlett.test bartlett.test.default bartlett.test.formula
> ### Keywords: htest
> 
> ### ** Examples
> 
> require(graphics)
> 
> plot(count ~ spray, data = InsectSprays)
> bartlett.test(InsectSprays$count, InsectSprays$spray)

	Bartlett test of homogeneity of variances

data:  InsectSprays$count and InsectSprays$spray
Bartlett's K-squared = 25.96, df = 5, p-value = 9.085e-05

> bartlett.test(count ~ spray, data = InsectSprays)

	Bartlett test of homogeneity of variances

data:  count by spray
Bartlett's K-squared = 25.96, df = 5, p-value = 9.085e-05

> 
> 
> 
> cleanEx()
> nameEx("binom.test")
> ### * binom.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: binom.test
> ### Title: Exact Binomial Test
> ### Aliases: binom.test
> ### Keywords: htest
> 
> ### ** Examples
> 
> ## Conover (1971), p. 97f.
> ## Under (the assumption of) simple Mendelian inheritance, a cross
> ##  between plants of two particular genotypes produces progeny 1/4 of
> ##  which are "dwarf" and 3/4 of which are "giant", respectively.
> ##  In an experiment to determine if this assumption is reasonable, a
> ##  cross results in progeny having 243 dwarf and 682 giant plants.
> ##  If "giant" is taken as success, the null hypothesis is that p =
> ##  3/4 and the alternative that p != 3/4.
> binom.test(c(682, 243), p = 3/4)

	Exact binomial test

data:  c(682, 243)
number of successes = 682, number of trials = 925, p-value = 0.3825
alternative hypothesis: true probability of success is not equal to 0.75
95 percent confidence interval:
 0.7076683 0.7654066
sample estimates:
probability of success 
             0.7372973 

> binom.test(682, 682 + 243, p = 3/4)   # The same.

	Exact binomial test

data:  682 and 682 + 243
number of successes = 682, number of trials = 925, p-value = 0.3825
alternative hypothesis: true probability of success is not equal to 0.75
95 percent confidence interval:
 0.7076683 0.7654066
sample estimates:
probability of success 
             0.7372973 

> ## => Data are in agreement with the null hypothesis.
> 
> 
> 
> cleanEx()
> nameEx("biplot.princomp")
> ### * biplot.princomp
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: biplot.princomp
> ### Title: Biplot for Principal Components
> ### Aliases: biplot.princomp biplot.prcomp
> ### Keywords: multivariate hplot
> 
> ### ** Examples
> 
> require(graphics)
> biplot(princomp(USArrests))
> 
> 
> 
> cleanEx()
> nameEx("birthday")
> ### * birthday
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: birthday
> ### Title: Probability of coincidences
> ### Aliases: qbirthday pbirthday
> ### Keywords: distribution
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## the standard version
> qbirthday() # 23
[1] 23
> ## probability of > 2 people with the same birthday
> pbirthday(23, coincident = 3)
[1] 0.01441541
> 
> ## examples from Diaconis & Mosteller p. 858.
> ## 'coincidence' is that husband, wife, daughter all born on the 16th
> qbirthday(classes = 30, coincident = 3) # approximately 18
[1] 18
> qbirthday(coincident = 4)  # exact value 187
[1] 187
> qbirthday(coincident = 10) # exact value 1181
[1] 1179
> 
> ## same 4-digit PIN number
> qbirthday(classes = 10^4)
[1] 119
> 
> ## 0.9 probability of three or more coincident birthdays
> qbirthday(coincident = 3, prob = 0.9)
[1] 135
> 
> ## Chance of 4 or more coincident birthdays in 150 people
> pbirthday(150, coincident = 4)
[1] 0.2690146
> 
> ## 100 or more coincident birthdays in 1000 people: very rare
> pbirthday(1000, coincident = 100)
[1] 1.531434e-113
> 
> 
> 
> cleanEx()
> nameEx("box.test")
> ### * box.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: Box.test
> ### Title: Box-Pierce and Ljung-Box Tests
> ### Aliases: Box.test
> ### Keywords: ts
> 
> ### ** Examples
> 
> x <- rnorm (100)
> Box.test (x, lag = 1)

	Box-Pierce test

data:  x
X-squared = 0.0013332, df = 1, p-value = 0.9709

> Box.test (x, lag = 1, type = "Ljung")

	Box-Ljung test

data:  x
X-squared = 0.0013736, df = 1, p-value = 0.9704

> 
> 
> 
> cleanEx()
> nameEx("cancor")
> ### * cancor
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: cancor
> ### Title: Canonical Correlations
> ### Aliases: cancor
> ### Keywords: multivariate
> 
> ### ** Examples
> 
> 
> cleanEx()
> nameEx("case.names")
> ### * case.names
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: case+variable.names
> ### Title: Case and Variable Names of Fitted Models
> ### Aliases: case.names case.names.lm variable.names variable.names.lm
> ### Keywords: regression models
> 
> ### ** Examples
> 
> x <- 1:20
> y <-  setNames(x + (x/4 - 2)^3 + rnorm(20, sd = 3),
+                paste("O", x, sep = "."))
> ww <- rep(1, 20); ww[13] <- 0
> summary(lmxy <- lm(y ~ x + I(x^2)+I(x^3) + I((x-10)^2), weights = ww),
+         correlation = TRUE)

Call:
lm(formula = y ~ x + I(x^2) + I(x^3) + I((x - 10)^2), weights = ww)

Weighted Residuals:
    Min      1Q  Median      3Q     Max 
-6.7160 -0.7047  0.0728  1.0174  3.9947 

Coefficients: (1 not defined because of singularities)
                Estimate Std. Error t value Pr(>|t|)    
(Intercept)   -10.967768   3.104498  -3.533 0.003013 ** 
x               5.524412   1.255354   4.401 0.000516 ***
I(x^2)         -0.542292   0.138460  -3.917 0.001374 ** 
I(x^3)          0.020905   0.004372   4.782 0.000242 ***
I((x - 10)^2)         NA         NA      NA       NA    
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 2.838 on 15 degrees of freedom
Multiple R-squared:  0.9702,	Adjusted R-squared:  0.9643 
F-statistic:   163 on 3 and 15 DF,  p-value: 1.14e-11

Correlation of Coefficients:
       (Intercept) x     I(x^2)
x      -0.90                   
I(x^2)  0.80       -0.97       
I(x^3) -0.73        0.93 -0.99 

> variable.names(lmxy)
[1] "(Intercept)" "x"           "I(x^2)"      "I(x^3)"     
> variable.names(lmxy, full = TRUE)  # includes the last
[1] "(Intercept)"   "x"             "I(x^2)"        "I(x^3)"       
[5] "I((x - 10)^2)"
> case.names(lmxy)
 [1] "O.1"  "O.2"  "O.3"  "O.4"  "O.5"  "O.6"  "O.7"  "O.8"  "O.9"  "O.10"
[11] "O.11" "O.12" "O.14" "O.15" "O.16" "O.17" "O.18" "O.19" "O.20"
> case.names(lmxy, full = TRUE)      # includes the 0-weight case
 [1] "O.1"  "O.2"  "O.3"  "O.4"  "O.5"  "O.6"  "O.7"  "O.8"  "O.9"  "O.10"
[11] "O.11" "O.12" "O.13" "O.14" "O.15" "O.16" "O.17" "O.18" "O.19" "O.20"
> 
> 
> 
> cleanEx()
> nameEx("checkMFClasses")
> ### * checkMFClasses
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: .checkMFClasses
> ### Title: Functions to Check the Type of Variables passed to Model Frames
> ### Aliases: .checkMFClasses .MFclass .getXlevels
> ### Keywords: utilities
> 
> ### ** Examples
> 
> sapply(warpbreaks, .MFclass) # "numeric" plus 2 x "factor"
   breaks      wool   tension 
"numeric"  "factor"  "factor" 
> sapply(iris,       .MFclass) # 4 x "numeric" plus "factor"
Sepal.Length  Sepal.Width Petal.Length  Petal.Width      Species 
   "numeric"    "numeric"    "numeric"    "numeric"     "factor" 
> 
> mf <- model.frame(Sepal.Width ~ Species,      iris)
> mc <- model.frame(Sepal.Width ~ Sepal.Length, iris)
> 
> .checkMFClasses("numeric", mc) # nothing else
> .checkMFClasses(c("numeric", "factor"), mf)
> 
> ## simple .getXlevels() cases :
> (xl <- .getXlevels(terms(mf), mf)) # a list with one entry " $ Species" with 3 levels:
$Species
[1] "setosa"     "versicolor" "virginica" 

> stopifnot(exprs = {
+   identical(xl$Species, levels(iris$Species))
+   identical(.getXlevels(terms(mc), mc), xl[0]) # a empty named list, as no factors
+   is.null(.getXlevels(terms(x~x), list(x=1)))
+ })
> 
> 
> 
> cleanEx()
> nameEx("chisq.test")
> ### * chisq.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: chisq.test
> ### Title: Pearson's Chi-squared Test for Count Data
> ### Aliases: chisq.test
> ### Keywords: htest distribution
> 
> ### ** Examples
> 
> 
> ## From Agresti(2007) p.39
> M <- as.table(rbind(c(762, 327, 468), c(484, 239, 477)))
> dimnames(M) <- list(gender = c("F", "M"),
+                     party = c("Democrat","Independent", "Republican"))
> (Xsq <- chisq.test(M))  # Prints test summary

	Pearson's Chi-squared test

data:  M
X-squared = 30.07, df = 2, p-value = 2.954e-07

> Xsq$observed   # observed counts (same as M)
      party
gender Democrat Independent Republican
     F      762         327        468
     M      484         239        477
> Xsq$expected   # expected counts under the null
      party
gender Democrat Independent Republican
     F 703.6714    319.6453   533.6834
     M 542.3286    246.3547   411.3166
> Xsq$residuals  # Pearson residuals
      party
gender   Democrat Independent Republican
     F  2.1988558   0.4113702 -2.8432397
     M -2.5046695  -0.4685829  3.2386734
> Xsq$stdres     # standardized residuals
      party
gender   Democrat Independent Republican
     F  4.5020535   0.6994517 -5.3159455
     M -4.5020535  -0.6994517  5.3159455
> 
> 
> ## Effect of simulating p-values
> x <- matrix(c(12, 5, 7, 7), ncol = 2)
> chisq.test(x)$p.value           # 0.4233
[1] 0.4233054
> chisq.test(x, simulate.p.value = TRUE, B = 10000)$p.value
[1] 0.2935706
>                                 # around 0.29!
> 
> ## Testing for population probabilities
> ## Case A. Tabulated data
> x <- c(A = 20, B = 15, C = 25)
> chisq.test(x)

	Chi-squared test for given probabilities

data:  x
X-squared = 2.5, df = 2, p-value = 0.2865

> chisq.test(as.table(x))             # the same

	Chi-squared test for given probabilities

data:  as.table(x)
X-squared = 2.5, df = 2, p-value = 0.2865

> x <- c(89,37,30,28,2)
> p <- c(40,20,20,15,5)
> try(
+ chisq.test(x, p = p)                # gives an error
+ )
Error in chisq.test(x, p = p) : probabilities must sum to 1.
> chisq.test(x, p = p, rescale.p = TRUE)

	Chi-squared test for given probabilities

data:  x
X-squared = 9.9901, df = 4, p-value = 0.04059

>                                 # works
> p <- c(0.40,0.20,0.20,0.19,0.01)
>                                 # Expected count in category 5
>                                 # is 1.86 < 5 ==> chi square approx.
> chisq.test(x, p = p)            #               maybe doubtful, but is ok!
Warning in chisq.test(x, p = p) :
  Chi-squared approximation may be incorrect

	Chi-squared test for given probabilities

data:  x
X-squared = 5.7947, df = 4, p-value = 0.215

> chisq.test(x, p = p, simulate.p.value = TRUE)

	Chi-squared test for given probabilities with simulated p-value (based
	on 2000 replicates)

data:  x
X-squared = 5.7947, df = NA, p-value = 0.2029

> 
> ## Case B. Raw data
> x <- trunc(5 * runif(100))
> chisq.test(table(x))            # NOT 'chisq.test(x)'!

	Chi-squared test for given probabilities

data:  table(x)
X-squared = 4.3, df = 4, p-value = 0.3669

> 
> 
> 
> cleanEx()
> nameEx("cmdscale")
> ### * cmdscale
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: cmdscale
> ### Title: Classical (Metric) Multidimensional Scaling
> ### Aliases: cmdscale
> ### Keywords: multivariate
> 
> ### ** Examples
> 
> require(graphics)
> 
> loc <- cmdscale(eurodist)
> x <- loc[, 1]
> y <- -loc[, 2] # reflect so North is at the top
> ## note asp = 1, to ensure Euclidean distances are represented correctly
> plot(x, y, type = "n", xlab = "", ylab = "", asp = 1, axes = FALSE,
+      main = "cmdscale(eurodist)")
> text(x, y, rownames(loc), cex = 0.6)
> 
> 
> 
> cleanEx()
> nameEx("coef")
> ### * coef
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: coef
> ### Title: Extract Model Coefficients
> ### Aliases: coef coefficients coef.default coef.aov
> ### Keywords: regression models
> 
> ### ** Examples
> 
> x <- 1:5; coef(lm(c(1:3, 7, 6) ~ x))
(Intercept)           x 
       -0.7         1.5 
> 
> 
> 
> cleanEx()
> nameEx("complete.cases")
> ### * complete.cases
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: complete.cases
> ### Title: Find Complete Cases
> ### Aliases: complete.cases
> ### Keywords: NA logic
> 
> ### ** Examples
> 
> x <- airquality[, -1] # x is a regression design matrix
> y <- airquality[,  1] # y is the corresponding response
> 
> stopifnot(complete.cases(y) != is.na(y))
> ok <- complete.cases(x, y)
> sum(!ok) # how many are not "ok" ?
[1] 42
> x <- x[ok,]
> y <- y[ok]
> 
> 
> 
> cleanEx()
> nameEx("confint")
> ### * confint
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: confint
> ### Title: Confidence Intervals for Model Parameters
> ### Aliases: confint confint.default confint.lm
> ### Keywords: models
> 
> ### ** Examples
> 
> fit <- lm(100/mpg ~ disp + hp + wt + am, data = mtcars)
> confint(fit)
                   2.5 %      97.5 %
(Intercept) -0.774822875 2.256118188
disp        -0.002867999 0.008273849
hp          -0.001400580 0.011949674
wt           0.380088737 1.622517536
am          -0.614677730 0.926307310
> confint(fit, "wt")
       2.5 %   97.5 %
wt 0.3800887 1.622518
> 
> 
> 
> 
> cleanEx()
> nameEx("constrOptim")
> ### * constrOptim
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: constrOptim
> ### Title: Linearly Constrained Optimization
> ### Aliases: constrOptim
> ### Keywords: optimize
> 
> ### ** Examples
> 
> 
> cleanEx()
> nameEx("contrast")
> ### * contrast
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: contrast
> ### Title: (Possibly Sparse) Contrast Matrices
> ### Aliases: contr.helmert contr.poly contr.sum contr.treatment contr.SAS
> ### Keywords: design regression array
> 
> ### ** Examples
> 
> (cH <- contr.helmert(4))
  [,1] [,2] [,3]
1   -1   -1   -1
2    1   -1   -1
3    0    2   -1
4    0    0    3
> apply(cH, 2, sum) # column sums are 0
[1] 0 0 0
> crossprod(cH) # diagonal -- columns are orthogonal
     [,1] [,2] [,3]
[1,]    2    0    0
[2,]    0    6    0
[3,]    0    0   12
> contr.helmert(4, contrasts = FALSE) # just the 4 x 4 identity matrix
  1 2 3 4
1 1 0 0 0
2 0 1 0 0
3 0 0 1 0
4 0 0 0 1
> 
> (cT <- contr.treatment(5))
  2 3 4 5
1 0 0 0 0
2 1 0 0 0
3 0 1 0 0
4 0 0 1 0
5 0 0 0 1
> all(crossprod(cT) == diag(4)) # TRUE: even orthonormal
[1] TRUE
> 
> (cT. <- contr.SAS(5))
  1 2 3 4
1 1 0 0 0
2 0 1 0 0
3 0 0 1 0
4 0 0 0 1
5 0 0 0 0
> all(crossprod(cT.) == diag(4)) # TRUE
[1] TRUE
> 
> zapsmall(cP <- contr.poly(3)) # Linear and Quadratic
             .L         .Q
[1,] -0.7071068  0.4082483
[2,]  0.0000000 -0.8164966
[3,]  0.7071068  0.4082483
> zapsmall(crossprod(cP), digits = 15) # orthonormal up to fuzz
   .L .Q
.L  1  0
.Q  0  1
> 
> 
> 
> cleanEx()
> nameEx("contrasts")
> ### * contrasts
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: contrasts
> ### Title: Get and Set Contrast Matrices
> ### Aliases: contrasts contrasts<-
> ### Keywords: design regression
> 
> ### ** Examples
> 
> utils::example(factor)

factor> (ff <- factor(substring("statistics", 1:10, 1:10), levels = letters))
 [1] s t a t i s t i c s
Levels: a b c d e f g h i j k l m n o p q r s t u v w x y z

factor> as.integer(ff)      # the internal codes
 [1] 19 20  1 20  9 19 20  9  3 19

factor> (f. <- factor(ff))  # drops the levels that do not occur
 [1] s t a t i s t i c s
Levels: a c i s t

factor> ff[, drop = TRUE]   # the same, more transparently
 [1] s t a t i s t i c s
Levels: a c i s t

factor> factor(letters[1:20], labels = "letter")
 [1] letter1  letter2  letter3  letter4  letter5  letter6  letter7  letter8 
 [9] letter9  letter10 letter11 letter12 letter13 letter14 letter15 letter16
[17] letter17 letter18 letter19 letter20
20 Levels: letter1 letter2 letter3 letter4 letter5 letter6 letter7 ... letter20

factor> class(ordered(4:1)) # "ordered", inheriting from "factor"
[1] "ordered" "factor" 

factor> z <- factor(LETTERS[3:1], ordered = TRUE)

factor> ## and "relational" methods work:
factor> stopifnot(sort(z)[c(1,3)] == range(z), min(z) < max(z))

factor> ## Don't show: 
factor> of <- ordered(ff)

factor> stopifnot(identical(range(of, rev(of)), of[3:2]),
factor+ 	  identical(max(of), of[2]))

factor> ## End(Don't show)
factor> 
factor> ## suppose you want "NA" as a level, and to allow missing values.
factor> (x <- factor(c(1, 2, NA), exclude = NULL))
[1] 1    2    <NA>
Levels: 1 2 <NA>

factor> is.na(x)[2] <- TRUE

factor> x  # [1] 1    <NA> <NA>
[1] 1    <NA> <NA>
Levels: 1 2 <NA>

factor> is.na(x)
[1] FALSE  TRUE FALSE

factor> # [1] FALSE  TRUE FALSE
factor> 
factor> ## More rational, since R 3.4.0 :
factor> factor(c(1:2, NA), exclude =  "" ) # keeps <NA> , as
[1] 1    2    <NA>
Levels: 1 2 <NA>

factor> factor(c(1:2, NA), exclude = NULL) # always did
[1] 1    2    <NA>
Levels: 1 2 <NA>

factor> ## exclude = <character>
factor> z # ordered levels 'A < B < C'
[1] C B A
Levels: A < B < C

factor> factor(z, exclude = "C") # does exclude
[1] <NA> B    A   
Levels: A < B

factor> factor(z, exclude = "B") # ditto
[1] C    <NA> A   
Levels: A < C

factor> ## Now, labels maybe duplicated:
factor> ## factor() with duplicated labels allowing to "merge levels"
factor> x <- c("Man", "Male", "Man", "Lady", "Female")

factor> ## Map from 4 different values to only two levels:
factor> (xf <- factor(x, levels = c("Male", "Man" , "Lady",   "Female"),
factor+                  labels = c("Male", "Male", "Female", "Female")))
[1] Male   Male   Male   Female Female
Levels: Male Female

factor> #> [1] Male   Male   Male   Female Female
factor> #> Levels: Male Female
factor> 
factor> ## Using addNA()
factor> Month <- airquality$Month

factor> table(addNA(Month))

   5    6    7    8    9 <NA> 
  31   30   31   31   30    0 

factor> table(addNA(Month, ifany = TRUE))

 5  6  7  8  9 
31 30 31 31 30 
> fff <- ff[, drop = TRUE]  # reduce to 5 levels.
> contrasts(fff) # treatment contrasts by default
  c i s t
a 0 0 0 0
c 1 0 0 0
i 0 1 0 0
s 0 0 1 0
t 0 0 0 1
> contrasts(C(fff, sum))
  [,1] [,2] [,3] [,4]
a    1    0    0    0
c    0    1    0    0
i    0    0    1    0
s    0    0    0    1
t   -1   -1   -1   -1
> contrasts(fff, contrasts = FALSE) # the 5x5 identity matrix
  a c i s t
a 1 0 0 0 0
c 0 1 0 0 0
i 0 0 1 0 0
s 0 0 0 1 0
t 0 0 0 0 1
> 
> contrasts(fff) <- contr.sum(5); contrasts(fff)  # set sum contrasts
  [,1] [,2] [,3] [,4]
a    1    0    0    0
c    0    1    0    0
i    0    0    1    0
s    0    0    0    1
t   -1   -1   -1   -1
> contrasts(fff, 2) <- contr.sum(5); contrasts(fff)  # set 2 contrasts
  [,1] [,2]
a    1    0
c    0    1
i    0    0
s    0    0
t   -1   -1
> # supply 2 contrasts, compute 2 more to make full set of 4.
> contrasts(fff) <- contr.sum(5)[, 1:2]; contrasts(fff)
  [,1] [,2]       [,3]       [,4]
a    1    0 -0.2471257  0.2688164
c    0    1 -0.2471257  0.2688164
i    0    0 -0.1498721 -0.8817814
s    0    0  0.8912491  0.0753323
t   -1   -1 -0.2471257  0.2688164
> 
> 
> 
> cleanEx()
> nameEx("convolve")
> ### * convolve
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: convolve
> ### Title: Convolution of Sequences via FFT
> ### Aliases: convolve
> ### Keywords: math dplot
> 
> ### ** Examples
> 
> require(graphics)
> 
> x <- c(0,0,0,100,0,0,0)
> y <- c(0,0,1, 2 ,1,0,0)/4
> zapsmall(convolve(x, y))         #  *NOT* what you first thought.
[1] 50 25  0  0  0  0 25
> zapsmall(convolve(x, y[3:5], type = "f")) # rather
[1]  0 25 50 25  0
> x <- rnorm(50)
> y <- rnorm(50)
> # Circular convolution *has* this symmetry:
> all.equal(convolve(x, y, conj = FALSE), rev(convolve(rev(y),x)))
[1] TRUE
> 
> n <- length(x <- -20:24)
> y <- (x-10)^2/1000 + rnorm(x)/8
> 
> Han <- function(y) # Hanning
+        convolve(y, c(1,2,1)/4, type = "filter")
> 
> plot(x, y, main = "Using  convolve(.) for Hanning filters")
> lines(x[-c(1  , n)      ], Han(y), col = "red")
> lines(x[-c(1:2, (n-1):n)], Han(Han(y)), lwd = 2, col = "dark blue")
> 
> 
> 
> cleanEx()
> nameEx("cophenetic")
> ### * cophenetic
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: cophenetic
> ### Title: Cophenetic Distances for a Hierarchical Clustering
> ### Aliases: cophenetic cophenetic.default cophenetic.dendrogram
> ### Keywords: cluster multivariate
> 
> ### ** Examples
> 
> require(graphics)
> 
> d1 <- dist(USArrests)
> hc <- hclust(d1, "ave")
> d2 <- cophenetic(hc)
> cor(d1, d2) # 0.7659
[1] 0.7658983
> 
> ## Example from Sneath & Sokal, Fig. 5-29, p.279
> d0 <- c(1,3.8,4.4,5.1, 4,4.2,5, 2.6,5.3, 5.4)
> attributes(d0) <- list(Size = 5, diag = TRUE)
> class(d0) <- "dist"
> names(d0) <- letters[1:5]
> d0
    1   2   3   4
2 1.0            
3 3.8 4.0        
4 4.4 4.2 2.6    
5 5.1 5.0 5.3 5.4
> utils::str(upgma <- hclust(d0, method = "average"))
List of 7
 $ merge      : int [1:4, 1:2] -1 -3 1 -5 -2 -4 2 3
 $ height     : num [1:4] 1 2.6 4.1 5.2
 $ order      : int [1:5] 5 1 2 3 4
 $ labels     : NULL
 $ method     : chr "average"
 $ call       : language hclust(d = d0, method = "average")
 $ dist.method: NULL
 - attr(*, "class")= chr "hclust"
> plot(upgma, hang = -1)
> #
> (d.coph <- cophenetic(upgma))
    1   2   3   4
2 1.0            
3 4.1 4.1        
4 4.1 4.1 2.6    
5 5.2 5.2 5.2 5.2
> cor(d0, d.coph) # 0.9911
[1] 0.9911351
> 
> 
> 
> cleanEx()
> nameEx("cor")
> ### * cor
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: cor
> ### Title: Correlation, Variance and Covariance (Matrices)
> ### Aliases: var cov cor cov2cor
> ### Keywords: univar multivariate array
> 
> ### ** Examples
> 
> var(1:10)  # 9.166667
[1] 9.166667
> 
> var(1:5, 1:5) # 2.5
[1] 2.5
> 
> ## Two simple vectors
> cor(1:10, 2:11) # == 1
[1] 1
> 
> ## Correlation Matrix of Multivariate sample:
> (Cl <- cor(longley))
             GNP.deflator       GNP Unemployed Armed.Forces Population
GNP.deflator    1.0000000 0.9915892  0.6206334    0.4647442  0.9791634
GNP             0.9915892 1.0000000  0.6042609    0.4464368  0.9910901
Unemployed      0.6206334 0.6042609  1.0000000   -0.1774206  0.6865515
Armed.Forces    0.4647442 0.4464368 -0.1774206    1.0000000  0.3644163
Population      0.9791634 0.9910901  0.6865515    0.3644163  1.0000000
Year            0.9911492 0.9952735  0.6682566    0.4172451  0.9939528
Employed        0.9708985 0.9835516  0.5024981    0.4573074  0.9603906
                  Year  Employed
GNP.deflator 0.9911492 0.9708985
GNP          0.9952735 0.9835516
Unemployed   0.6682566 0.5024981
Armed.Forces 0.4172451 0.4573074
Population   0.9939528 0.9603906
Year         1.0000000 0.9713295
Employed     0.9713295 1.0000000
> ## Graphical Correlation Matrix:
> symnum(Cl) # highly correlated
             GNP. GNP U A P Y E
GNP.deflator 1                 
GNP          B    1            
Unemployed   ,    ,   1        
Armed.Forces .    .     1      
Population   B    B   , . 1    
Year         B    B   , . B 1  
Employed     B    B   . . B B 1
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> 
> ## Spearman's rho  and  Kendall's tau
> symnum(clS <- cor(longley, method = "spearman"))
             GNP. GNP U A P Y E
GNP.deflator 1                 
GNP          B    1            
Unemployed   ,    ,   1        
Armed.Forces          . 1      
Population   B    B   ,   1    
Year         B    B   ,   1 1  
Employed     B    B   .   B B 1
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> symnum(clK <- cor(longley, method = "kendall"))
             GNP. GNP U A P Y E
GNP.deflator 1                 
GNP          B    1            
Unemployed   .    .   1        
Armed.Forces            1      
Population   B    B   .   1    
Year         B    B   .   1 1  
Employed     *    *   .   + + 1
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> ## How much do they differ?
> i <- lower.tri(Cl)
> cor(cbind(P = Cl[i], S = clS[i], K = clK[i]))
          P         S         K
P 1.0000000 0.9802390 0.9572562
S 0.9802390 1.0000000 0.9742171
K 0.9572562 0.9742171 1.0000000
> 
> 
> ## cov2cor() scales a covariance matrix by its diagonal
> ##           to become the correlation matrix.
> cov2cor # see the function definition {and learn ..}
function (V) 
{
    p <- (d <- dim(V))[1L]
    if (!is.numeric(V) || length(d) != 2L || p != d[2L]) 
        stop("'V' is not a square numeric matrix")
    Is <- sqrt(1/diag(V))
    if (any(!is.finite(Is))) 
        warning("diag(.) had 0 or NA entries; non-finite result is doubtful")
    r <- V
    r[] <- Is * V * rep(Is, each = p)
    r[cbind(1L:p, 1L:p)] <- 1
    r
}
<bytecode: 0x716e178>
<environment: namespace:stats>
> stopifnot(all.equal(Cl, cov2cor(cov(longley))),
+           all.equal(cor(longley, method = "kendall"),
+             cov2cor(cov(longley, method = "kendall"))))
> 
> ##--- Missing value treatment:
> C1 <- cov(swiss)
> range(eigen(C1, only.values = TRUE)$values) # 6.19        1921
[1]    6.191249 1921.562488
> 
> ## swM := "swiss" with  3 "missing"s :
> swM <- swiss
> colnames(swM) <- abbreviate(colnames(swiss), minlength=6)
> swM[1,2] <- swM[7,3] <- swM[25,5] <- NA # create 3 "missing"
> 
> ## Consider all 5 "use" cases :
> (C. <- cov(swM)) # use="everything"  quite a few NA's in cov.matrix
          Frtlty Agrclt Exmntn     Eductn Cathlc    Infn.M
Frtlty 156.04250     NA     NA -79.729510     NA 15.156193
Agrclt        NA     NA     NA         NA     NA        NA
Exmntn        NA     NA     NA         NA     NA        NA
Eductn -79.72951     NA     NA  92.456059     NA -2.781684
Cathlc        NA     NA     NA         NA     NA        NA
Infn.M  15.15619     NA     NA  -2.781684     NA  8.483802
> try(cov(swM, use = "all")) # Error: missing obs...
Error in cov(swM, use = "all") : missing observations in cov/cor
> C2 <- cov(swM, use = "complete")
> stopifnot(identical(C2, cov(swM, use = "na.or.complete")))
> range(eigen(C2, only.values = TRUE)$values) # 6.46   1930
[1]    6.462385 1930.505982
> C3 <- cov(swM, use = "pairwise")
> range(eigen(C3, only.values = TRUE)$values) # 6.19   1938
[1]    6.194469 1938.033663
> 
> ## Kendall's tau doesn't change much:
> symnum(Rc <- cor(swM, method = "kendall", use = "complete"))
       F A Ex Ed C I
Frtlty 1            
Agrclt   1          
Exmntn . . 1        
Eductn . . .  1     
Cathlc     .     1  
Infn.M             1
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> symnum(Rp <- cor(swM, method = "kendall", use = "pairwise"))
       F A Ex Ed C I
Frtlty 1            
Agrclt   1          
Exmntn . . 1        
Eductn . . .  1     
Cathlc     .     1  
Infn.M .           1
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> symnum(R. <- cor(swiss, method = "kendall"))
                 F A Ex Ed C I
Fertility        1            
Agriculture        1          
Examination      . . 1        
Education        . . .  1     
Catholic             .     1  
Infant.Mortality .           1
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> 
> ## "pairwise" is closer componentwise,
> summary(abs(c(1 - Rp/R.)))
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
0.00000 0.00000 0.04481 0.09573 0.15214 0.53941 
> summary(abs(c(1 - Rc/R.)))
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
0.00000 0.02021 0.08482 0.50675 0.16192 7.08509 
> 
> ## but "complete" is closer in Eigen space:
> EV <- function(m) eigen(m, only.values=TRUE)$values
> summary(abs(1 - EV(Rp)/EV(R.)) / abs(1 - EV(Rc)/EV(R.)))
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
 0.8942  1.1464  1.2452  1.3732  1.3722  2.3265 
> 
> 
> 
> cleanEx()
> nameEx("cor.test")
> ### * cor.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: cor.test
> ### Title: Test for Association/Correlation Between Paired Samples
> ### Aliases: cor.test cor.test.default cor.test.formula
> ### Keywords: htest
> 
> ### ** Examples
> 
> ## Hollander & Wolfe (1973), p. 187f.
> ## Assessment of tuna quality.  We compare the Hunter L measure of
> ##  lightness to the averages of consumer panel scores (recoded as
> ##  integer values from 1 to 6 and averaged over 80 such values) in
> ##  9 lots of canned tuna.
> 
> x <- c(44.4, 45.9, 41.9, 53.3, 44.7, 44.1, 50.7, 45.2, 60.1)
> y <- c( 2.6,  3.1,  2.5,  5.0,  3.6,  4.0,  5.2,  2.8,  3.8)
> 
> ##  The alternative hypothesis of interest is that the
> ##  Hunter L value is positively associated with the panel score.
> 
> cor.test(x, y, method = "kendall", alternative = "greater")

	Kendall's rank correlation tau

data:  x and y
T = 26, p-value = 0.05972
alternative hypothesis: true tau is greater than 0
sample estimates:
      tau 
0.4444444 

> ## => p=0.05972
> 
> cor.test(x, y, method = "kendall", alternative = "greater",
+          exact = FALSE) # using large sample approximation

	Kendall's rank correlation tau

data:  x and y
z = 1.6681, p-value = 0.04765
alternative hypothesis: true tau is greater than 0
sample estimates:
      tau 
0.4444444 

> ## => p=0.04765
> 
> ## Compare this to
> cor.test(x, y, method = "spearm", alternative = "g")

	Spearman's rank correlation rho

data:  x and y
S = 48, p-value = 0.0484
alternative hypothesis: true rho is greater than 0
sample estimates:
rho 
0.6 

> cor.test(x, y,                    alternative = "g")

	Pearson's product-moment correlation

data:  x and y
t = 1.8411, df = 7, p-value = 0.05409
alternative hypothesis: true correlation is greater than 0
95 percent confidence interval:
 -0.02223023  1.00000000
sample estimates:
      cor 
0.5711816 

> 
> ## Formula interface.
> require(graphics)
> pairs(USJudgeRatings)
> cor.test(~ CONT + INTG, data = USJudgeRatings)

	Pearson's product-moment correlation

data:  CONT and INTG
t = -0.8605, df = 41, p-value = 0.3945
alternative hypothesis: true correlation is not equal to 0
95 percent confidence interval:
 -0.4168591  0.1741182
sample estimates:
       cor 
-0.1331909 

> 
> 
> 
> cleanEx()
> nameEx("cov.wt")
> ### * cov.wt
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: cov.wt
> ### Title: Weighted Covariance Matrices
> ### Aliases: cov.wt
> ### Keywords: multivariate
> 
> ### ** Examples
> 
>  (xy <- cbind(x = 1:10, y = c(1:3, 8:5, 8:10)))
       x  y
 [1,]  1  1
 [2,]  2  2
 [3,]  3  3
 [4,]  4  8
 [5,]  5  7
 [6,]  6  6
 [7,]  7  5
 [8,]  8  8
 [9,]  9  9
[10,] 10 10
>  w1 <- c(0,0,0,1,1,1,1,1,0,0)
>  cov.wt(xy, wt = w1) # i.e. method = "unbiased"
$cov
     x    y
x  2.5 -0.5
y -0.5  1.7

$center
  x   y 
6.0 6.8 

$n.obs
[1] 10

$wt
 [1] 0.0 0.0 0.0 0.2 0.2 0.2 0.2 0.2 0.0 0.0

>  cov.wt(xy, wt = w1, method = "ML", cor = TRUE)
$cov
     x     y
x  2.0 -0.40
y -0.4  1.36

$center
  x   y 
6.0 6.8 

$n.obs
[1] 10

$wt
 [1] 0.0 0.0 0.0 0.2 0.2 0.2 0.2 0.2 0.0 0.0

$cor
           x          y
x  1.0000000 -0.2425356
y -0.2425356  1.0000000

> 
> 
> 
> cleanEx()
> nameEx("cpgram")
> ### * cpgram
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: cpgram
> ### Title: Plot Cumulative Periodogram
> ### Aliases: cpgram
> ### Keywords: ts hplot
> 
> ### ** Examples
> 
> require(graphics)
> 
> par(pty = "s", mfrow = c(1,2))
> cpgram(lh)
> lh.ar <- ar(lh, order.max = 9)
> cpgram(lh.ar$resid, main = "AR(3) fit to lh")
> 
> cpgram(ldeaths)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("cutree")
> ### * cutree
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: cutree
> ### Title: Cut a Tree into Groups of Data
> ### Aliases: cutree
> ### Keywords: multivariate cluster
> 
> ### ** Examples
> 
> hc <- hclust(dist(USArrests))
> 
> cutree(hc, k = 1:5) #k = 1 is trivial
               1 2 3 4 5
Alabama        1 1 1 1 1
Alaska         1 1 1 1 1
Arizona        1 1 1 1 1
Arkansas       1 2 2 2 2
California     1 1 1 1 1
Colorado       1 2 2 2 2
Connecticut    1 2 3 3 3
Delaware       1 1 1 1 1
Florida        1 1 1 4 4
Georgia        1 2 2 2 2
Hawaii         1 2 3 3 5
Idaho          1 2 3 3 3
Illinois       1 1 1 1 1
Indiana        1 2 3 3 3
Iowa           1 2 3 3 5
Kansas         1 2 3 3 3
Kentucky       1 2 3 3 3
Louisiana      1 1 1 1 1
Maine          1 2 3 3 5
Maryland       1 1 1 1 1
Massachusetts  1 2 2 2 2
Michigan       1 1 1 1 1
Minnesota      1 2 3 3 5
Mississippi    1 1 1 1 1
Missouri       1 2 2 2 2
Montana        1 2 3 3 3
Nebraska       1 2 3 3 3
Nevada         1 1 1 1 1
New Hampshire  1 2 3 3 5
New Jersey     1 2 2 2 2
New Mexico     1 1 1 1 1
New York       1 1 1 1 1
North Carolina 1 1 1 4 4
North Dakota   1 2 3 3 5
Ohio           1 2 3 3 3
Oklahoma       1 2 2 2 2
Oregon         1 2 2 2 2
Pennsylvania   1 2 3 3 3
Rhode Island   1 2 2 2 2
South Carolina 1 1 1 1 1
South Dakota   1 2 3 3 5
Tennessee      1 2 2 2 2
Texas          1 2 2 2 2
Utah           1 2 3 3 3
Vermont        1 2 3 3 5
Virginia       1 2 2 2 2
Washington     1 2 2 2 2
West Virginia  1 2 3 3 5
Wisconsin      1 2 3 3 5
Wyoming        1 2 2 2 2
> cutree(hc, h = 250)
       Alabama         Alaska        Arizona       Arkansas     California 
             1              1              1              2              1 
      Colorado    Connecticut       Delaware        Florida        Georgia 
             2              2              1              1              2 
        Hawaii          Idaho       Illinois        Indiana           Iowa 
             2              2              1              2              2 
        Kansas       Kentucky      Louisiana          Maine       Maryland 
             2              2              1              2              1 
 Massachusetts       Michigan      Minnesota    Mississippi       Missouri 
             2              1              2              1              2 
       Montana       Nebraska         Nevada  New Hampshire     New Jersey 
             2              2              1              2              2 
    New Mexico       New York North Carolina   North Dakota           Ohio 
             1              1              1              2              2 
      Oklahoma         Oregon   Pennsylvania   Rhode Island South Carolina 
             2              2              2              2              1 
  South Dakota      Tennessee          Texas           Utah        Vermont 
             2              2              2              2              2 
      Virginia     Washington  West Virginia      Wisconsin        Wyoming 
             2              2              2              2              2 
> 
> ## Compare the 2 and 4 grouping:
> g24 <- cutree(hc, k = c(2,4))
> table(grp2 = g24[,"2"], grp4 = g24[,"4"])
    grp4
grp2  1  2  3  4
   1 14  0  0  2
   2  0 14 20  0
> 
> 
> 
> cleanEx()
> nameEx("decompose")
> ### * decompose
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: decompose
> ### Title: Classical Seasonal Decomposition by Moving Averages
> ### Aliases: decompose plot.decomposed.ts
> ### Keywords: ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> m <- decompose(co2)
> m$figure
 [1] -0.05359649  0.61055921  1.37564693  2.51682018  3.00028509  2.32921053
 [7]  0.81293860 -1.25052632 -3.05458333 -3.25194079 -2.06969298 -0.96512061
> plot(m)
> 
> ## example taken from Kendall/Stuart
> x <- c(-50, 175, 149, 214, 247, 237, 225, 329, 729, 809,
+        530, 489, 540, 457, 195, 176, 337, 239, 128, 102, 232, 429, 3,
+        98, 43, -141, -77, -13, 125, 361, -45, 184)
> x <- ts(x, start = c(1951, 1), end = c(1958, 4), frequency = 4)
> m <- decompose(x)
> ## seasonal figure: 6.25, 8.62, -8.84, -6.03
> round(decompose(x)$figure / 10, 2)
[1]  6.25  8.62 -8.84 -6.03
> 
> 
> 
> cleanEx()
> nameEx("delete.response")
> ### * delete.response
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: delete.response
> ### Title: Modify Terms Objects
> ### Aliases: reformulate drop.terms delete.response [.terms
> ### Keywords: programming
> 
> ### ** Examples
> 
> ff <- y ~ z + x + w
> tt <- terms(ff)
> tt
y ~ z + x + w
attr(,"variables")
list(y, z, x, w)
attr(,"factors")
  z x w
y 0 0 0
z 1 0 0
x 0 1 0
w 0 0 1
attr(,"term.labels")
[1] "z" "x" "w"
attr(,"order")
[1] 1 1 1
attr(,"intercept")
[1] 1
attr(,"response")
[1] 1
attr(,".Environment")
<environment: R_GlobalEnv>
> delete.response(tt)
~z + x + w
attr(,"variables")
list(z, x, w)
attr(,"factors")
  z x w
z 1 0 0
x 0 1 0
w 0 0 1
attr(,"term.labels")
[1] "z" "x" "w"
attr(,"order")
[1] 1 1 1
attr(,"intercept")
[1] 1
attr(,"response")
[1] 0
attr(,".Environment")
<environment: R_GlobalEnv>
> drop.terms(tt, 2:3, keep.response = TRUE)
y ~ z
attr(,"variables")
list(y, z)
attr(,"factors")
  z
y 0
z 1
attr(,"term.labels")
[1] "z"
attr(,"order")
[1] 1
attr(,"intercept")
[1] 1
attr(,"response")
[1] 1
attr(,".Environment")
<environment: R_GlobalEnv>
> tt[-1]
y ~ x + w
attr(,"variables")
list(y, x, w)
attr(,"factors")
  x w
y 0 0
x 1 0
w 0 1
attr(,"term.labels")
[1] "x" "w"
attr(,"order")
[1] 1 1
attr(,"intercept")
[1] 1
attr(,"response")
[1] 1
attr(,".Environment")
<environment: R_GlobalEnv>
> tt[2:3]
y ~ x + w
attr(,"variables")
list(y, x, w)
attr(,"factors")
  x w
y 0 0
x 1 0
w 0 1
attr(,"term.labels")
[1] "x" "w"
attr(,"order")
[1] 1 1
attr(,"intercept")
[1] 1
attr(,"response")
[1] 1
attr(,".Environment")
<environment: R_GlobalEnv>
> reformulate(attr(tt, "term.labels"))
~z + x + w
> 
> ## keep LHS :
> reformulate("x*w", ff[[2]])
y ~ x * w
> fS <- surv(ft, case) ~ a + b
> reformulate(c("a", "b*f"), fS[[2]])
surv(ft, case) ~ a + b * f
> 
> ## using non-syntactic names:
> reformulate(c("`P/E`", "`% Growth`"), response = as.name("+-"))
`+-` ~ `P/E` + `% Growth`
> 
> x <- c("a name", "another name")
> try( reformulate(x) ) # -> Error ..... unexpected symbol
Error in str2lang(termtext) : <text>:1:3: unexpected symbol
1: a name
      ^
> ## rather backquote the strings in x :
> reformulate(sprintf("`%s`", x))
~`a name` + `another name`
> 
> stopifnot(identical(      ~ var, reformulate("var")),
+           identical(~ a + b + c, reformulate(letters[1:3])),
+           identical(  y ~ a + b, reformulate(letters[1:2], "y"))
+          )
> 
> 
> 
> cleanEx()
> nameEx("dendrapply")
> ### * dendrapply
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: dendrapply
> ### Title: Apply a Function to All Nodes of a Dendrogram
> ### Aliases: dendrapply
> ### Keywords: iteration
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## a smallish simple dendrogram
> dhc <- as.dendrogram(hc <- hclust(dist(USArrests), "ave"))
> (dhc21 <- dhc[[2]][[1]])
'dendrogram' with 2 branches and 14 members total, at height 44.83793 
> 
> ## too simple:
> dendrapply(dhc21, function(n) utils::str(attributes(n)))
List of 4
 $ members : int 14
 $ midpoint: num 6.8
 $ height  : num 44.8
 $ class   : chr "dendrogram"
List of 4
 $ members : int 8
 $ midpoint: num 3.34
 $ height  : num 26.7
 $ class   : chr "dendrogram"
List of 4
 $ members : int 5
 $ midpoint: num 0.938
 $ height  : num 16.4
 $ class   : chr "dendrogram"
List of 5
 $ members: int 1
 $ height : num 0
 $ label  : chr "Washington"
 $ leaf   : logi TRUE
 $ class  : chr "dendrogram"
List of 4
 $ members : int 4
 $ midpoint: num 0.875
 $ height  : num 12.9
 $ class   : chr "dendrogram"
List of 5
 $ members: int 1
 $ height : num 0
 $ label  : chr "Oregon"
 $ leaf   : logi TRUE
 $ class  : chr "dendrogram"
List of 4
 $ members : int 3
 $ midpoint: num 0.75
 $ height  : num 10.7
 $ class   : chr "dendrogram"
List of 5
 $ members: int 1
 $ height : num 0
 $ label  : chr "Wyoming"
 $ leaf   : logi TRUE
 $ class  : chr "dendrogram"
List of 4
 $ members : int 2
 $ midpoint: num 0.5
 $ height  : num 7.36
 $ class   : chr "dendrogram"
List of 5
 $ label  : chr "Oklahoma"
 $ members: int 1
 $ height : num 0
 $ leaf   : logi TRUE
 $ class  : chr "dendrogram"
List of 5
 $ label  : chr "Virginia"
 $ members: int 1
 $ height : num 0
 $ leaf   : logi TRUE
 $ class  : chr "dendrogram"
List of 4
 $ members : int 3
 $ midpoint: num 0.75
 $ height  : num 22.6
 $ class   : chr "dendrogram"
List of 5
 $ members: int 1
 $ height : num 0
 $ label  : chr "Rhode Island"
 $ leaf   : logi TRUE
 $ class  : chr "dendrogram"
List of 4
 $ members : int 2
 $ midpoint: num 0.5
 $ height  : num 11.5
 $ class   : chr "dendrogram"
List of 5
 $ label  : chr "Massachusetts"
 $ members: int 1
 $ height : num 0
 $ leaf   : logi TRUE
 $ class  : chr "dendrogram"
List of 5
 $ label  : chr "New Jersey"
 $ members: int 1
 $ height : num 0
 $ leaf   : logi TRUE
 $ class  : chr "dendrogram"
List of 4
 $ members : int 6
 $ midpoint: num 2.25
 $ height  : num 29.1
 $ class   : chr "dendrogram"
List of 4
 $ members : int 3
 $ midpoint: num 0.75
 $ height  : num 20.2
 $ class   : chr "dendrogram"
List of 5
 $ members: int 1
 $ height : num 0
 $ label  : chr "Missouri"
 $ leaf   : logi TRUE
 $ class  : chr "dendrogram"
List of 4
 $ members : int 2
 $ midpoint: num 0.5
 $ height  : num 12.6
 $ class   : chr "dendrogram"
List of 5
 $ label  : chr "Arkansas"
 $ members: int 1
 $ height : num 0
 $ leaf   : logi TRUE
 $ class  : chr "dendrogram"
List of 5
 $ label  : chr "Tennessee"
 $ members: int 1
 $ height : num 0
 $ leaf   : logi TRUE
 $ class  : chr "dendrogram"
List of 4
 $ members : int 3
 $ midpoint: num 0.75
 $ height  : num 24
 $ class   : chr "dendrogram"
List of 5
 $ members: int 1
 $ height : num 0
 $ label  : chr "Georgia"
 $ leaf   : logi TRUE
 $ class  : chr "dendrogram"
List of 4
 $ members : int 2
 $ midpoint: num 0.5
 $ height  : num 14.5
 $ class   : chr "dendrogram"
List of 5
 $ label  : chr "Colorado"
 $ members: int 1
 $ height : num 0
 $ leaf   : logi TRUE
 $ class  : chr "dendrogram"
List of 5
 $ label  : chr "Texas"
 $ members: int 1
 $ height : num 0
 $ leaf   : logi TRUE
 $ class  : chr "dendrogram"
[[1]]
[[1]][[1]]
[[1]][[1]][[1]]
NULL

[[1]][[1]][[2]]
[[1]][[1]][[2]][[1]]
NULL

[[1]][[1]][[2]][[2]]
[[1]][[1]][[2]][[2]][[1]]
NULL

[[1]][[1]][[2]][[2]][[2]]
[[1]][[1]][[2]][[2]][[2]][[1]]
NULL

[[1]][[1]][[2]][[2]][[2]][[2]]
NULL


[[1]][[2]]
[[1]][[2]][[1]]
NULL

[[1]][[2]][[2]]
[[1]][[2]][[2]][[1]]
NULL

[[1]][[2]][[2]][[2]]
NULL


[[2]]
[[2]][[1]]
[[2]][[1]][[1]]
NULL

[[2]][[1]][[2]]
[[2]][[1]][[2]][[1]]
NULL

[[2]][[1]][[2]][[2]]
NULL


[[2]][[2]]
[[2]][[2]][[1]]
NULL

[[2]][[2]][[2]]
[[2]][[2]][[2]][[1]]
NULL

[[2]][[2]][[2]][[2]]
NULL


> 
> ## toy example to set colored leaf labels :
> local({
+   colLab <<- function(n) {
+       if(is.leaf(n)) {
+         a <- attributes(n)
+         i <<- i+1
+         attr(n, "nodePar") <-
+             c(a$nodePar, list(lab.col = mycols[i], lab.font = i%%3))
+       }
+       n
+   }
+   mycols <- grDevices::rainbow(attr(dhc21,"members"))
+   i <- 0
+  })
> dL <- dendrapply(dhc21, colLab)
> op <- par(mfrow = 2:1)
>  plot(dhc21)
>  plot(dL) ## --> colored labels!
> par(op)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("dendrogram")
> ### * dendrogram
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: dendrogram
> ### Title: General Tree Structures
> ### Aliases: dendrogram as.dendrogram as.dendrogram.dendrogram
> ###   as.dendrogram.hclust as.hclust.dendrogram cut.dendrogram
> ###   [[.dendrogram merge.dendrogram nobs.dendrogram plot.dendrogram
> ###   print.dendrogram rev.dendrogram str.dendrogram is.leaf
> ### Keywords: multivariate tree hplot
> 
> ### ** Examples
> 
> require(graphics); require(utils)
> 
> hc <- hclust(dist(USArrests), "ave")
> (dend1 <- as.dendrogram(hc)) # "print()" method
'dendrogram' with 2 branches and 50 members total, at height 152.314 
> str(dend1)          # "str()" method
--[dendrogram w/ 2 branches and 50 members at h = 152]
  |--[dendrogram w/ 2 branches and 16 members at h = 77.6]
  |  |--[dendrogram w/ 2 branches and 2 members at h = 38.5]
  |  |  |--leaf "Florida" 
  |  |  `--leaf "North Carolina" 
  |  `--[dendrogram w/ 2 branches and 14 members at h = 44.3]
  |     |--[dendrogram w/ 2 branches and 4 members at h = 28]
  |     |  |--leaf "California" 
  |     |  `--[dendrogram w/ 2 branches and 3 members at h = 15.5]
  |     |     |--leaf "Maryland" 
  |     |     `--[dendrogram w/ 2 branches and 2 members at h = 13.9]
  |     |        |--leaf "Arizona" 
  |     |        `--leaf "New Mexico" 
  |     `--[dendrogram w/ 2 branches and 10 members at h = 39.4]
  |        |--[dendrogram w/ 2 branches and 7 members at h = 26.4]
  |        |  |--[dendrogram w/ 2 branches and 3 members at h = 16.9]
  |        |  |  |--leaf "Delaware" 
  |        |  |  `--[dendrogram w/ 2 branches and 2 members at h = 15.5]
  |        |  |     |--leaf "Alabama" 
  |        |  |     `--leaf "Louisiana" 
  |        |  `--[dendrogram w/ 2 branches and 4 members at h = 18.4]
  |        |     |--[dendrogram w/ 2 branches and 2 members at h = 6.24]
  |        |     |  |--leaf "Illinois" 
  |        |     |  `--leaf "New York" 
  |        |     `--[dendrogram w/ 2 branches and 2 members at h = 13.3]
  |        |        |--leaf "Michigan" 
  |        |        `--leaf "Nevada" 
  |        `--[dendrogram w/ 2 branches and 3 members at h = 28.1]
  |           |--leaf "Alaska" 
  |           `--[dendrogram w/ 2 branches and 2 members at h = 21.2]
  |              |--leaf "Mississippi" 
  |              `--leaf "South Carolina" 
  `--[dendrogram w/ 2 branches and 34 members at h = 89.2]
     |--[dendrogram w/ 2 branches and 14 members at h = 44.8]
     |  |--[dendrogram w/ 2 branches and 8 members at h = 26.7]
     |  |  |--[dendrogram w/ 2 branches and 5 members at h = 16.4]
     |  |  |  |--leaf "Washington" 
     |  |  |  `--[dendrogram w/ 2 branches and 4 members at h = 12.9]
     |  |  |     |--leaf "Oregon" 
     |  |  |     `--[dendrogram w/ 2 branches and 3 members at h = 10.7]
     |  |  |        |--leaf "Wyoming" 
     |  |  |        `--[dendrogram w/ 2 branches and 2 members at h = 7.36]
     |  |  |           |--leaf "Oklahoma" 
     |  |  |           `--leaf "Virginia" 
     |  |  `--[dendrogram w/ 2 branches and 3 members at h = 22.6]
     |  |     |--leaf "Rhode Island" 
     |  |     `--[dendrogram w/ 2 branches and 2 members at h = 11.5]
     |  |        |--leaf "Massachusetts" 
     |  |        `--leaf "New Jersey" 
     |  `--[dendrogram w/ 2 branches and 6 members at h = 29.1]
     |     |--[dendrogram w/ 2 branches and 3 members at h = 20.2]
     |     |  |--leaf "Missouri" 
     |     |  `--[dendrogram w/ 2 branches and 2 members at h = 12.6]
     |     |     |--leaf "Arkansas" 
     |     |     `--leaf "Tennessee" 
     |     `--[dendrogram w/ 2 branches and 3 members at h = 24]
     |        |--leaf "Georgia" 
     |        `--[dendrogram w/ 2 branches and 2 members at h = 14.5]
     |           |--leaf "Colorado" 
     |           `--leaf "Texas" 
     `--[dendrogram w/ 2 branches and 20 members at h = 54.7]
        |--[dendrogram w/ 2 branches and 10 members at h = 20.6]
        |  |--[dendrogram w/ 2 branches and 4 members at h = 15]
        |  |  |--leaf "Idaho" 
        |  |  `--[dendrogram w/ 2 branches and 3 members at h = 12.4]
        |  |     |--leaf "Nebraska" 
        |  |     `--[dendrogram w/ 2 branches and 2 members at h = 3.83]
        |  |        |--leaf "Kentucky" 
        |  |        `--leaf "Montana" 
        |  `--[dendrogram w/ 2 branches and 6 members at h = 15.1]
        |     |--[dendrogram w/ 2 branches and 2 members at h = 6.64]
        |     |  |--leaf "Ohio" 
        |     |  `--leaf "Utah" 
        |     `--[dendrogram w/ 2 branches and 4 members at h = 13.4]
        |        |--[dendrogram w/ 2 branches and 2 members at h = 3.93]
        |        |  |--leaf "Indiana" 
        |        |  `--leaf "Kansas" 
        |        `--[dendrogram w/ 2 branches and 2 members at h = 8.03]
        |           |--leaf "Connecticut" 
        |           `--leaf "Pennsylvania" 
        `--[dendrogram w/ 2 branches and 10 members at h = 41.1]
           |--leaf "Hawaii" 
           `--[dendrogram w/ 2 branches and 9 members at h = 33.1]
              |--[dendrogram w/ 2 branches and 3 members at h = 10.8]
              |  |--leaf "West Virginia" 
              |  `--[dendrogram w/ 2 branches and 2 members at h = 8.54]
              |     |--leaf "Maine" 
              |     `--leaf "South Dakota" 
              `--[dendrogram w/ 2 branches and 6 members at h = 27.8]
                 |--[dendrogram w/ 2 branches and 2 members at h = 13]
                 |  |--leaf "North Dakota" 
                 |  `--leaf "Vermont" 
                 `--[dendrogram w/ 2 branches and 4 members at h = 19]
                    |--leaf "Minnesota" 
                    `--[dendrogram w/ 2 branches and 3 members at h = 10.2]
                       |--leaf "Wisconsin" 
                       `--[dendrogram w/ 2 branches and 2 members at h = 2.29]
                          |--leaf "Iowa" 
                          `--leaf "New Hampshire" 
> str(dend1, max.level = 2, last.str =  "'") # only the first two sub-levels
--[dendrogram w/ 2 branches and 50 members at h = 152]
  |--[dendrogram w/ 2 branches and 16 members at h = 77.6]
  |  |--[dendrogram w/ 2 branches and 2 members at h = 38.5] ..
  |  '--[dendrogram w/ 2 branches and 14 members at h = 44.3] ..
  '--[dendrogram w/ 2 branches and 34 members at h = 89.2]
     |--[dendrogram w/ 2 branches and 14 members at h = 44.8] ..
     '--[dendrogram w/ 2 branches and 20 members at h = 54.7] ..
> oo <- options(str.dendrogram.last = "\\") # yet another possibility
> str(dend1, max.level = 2) # only the first two sub-levels
--[dendrogram w/ 2 branches and 50 members at h = 152]
  |--[dendrogram w/ 2 branches and 16 members at h = 77.6]
  |  |--[dendrogram w/ 2 branches and 2 members at h = 38.5] ..
  |  --[dendrogram w/ 2 branches and 14 members at h = 44.3] ..
  --[dendrogram w/ 2 branches and 34 members at h = 89.2]
     |--[dendrogram w/ 2 branches and 14 members at h = 44.8] ..
     --[dendrogram w/ 2 branches and 20 members at h = 54.7] ..
> options(oo)  # .. resetting them
> 
> op <- par(mfrow =  c(2,2), mar = c(5,2,1,4))
> plot(dend1)
> ## "triangle" type and show inner nodes:
> plot(dend1, nodePar = list(pch = c(1,NA), cex = 0.8, lab.cex = 0.8),
+       type = "t", center = TRUE)
> plot(dend1, edgePar = list(col = 1:2, lty = 2:3),
+      dLeaf = 1, edge.root = TRUE)
> plot(dend1, nodePar = list(pch = 2:1, cex = .4*2:1, col = 2:3),
+      horiz = TRUE)
> 
> ## simple test for as.hclust() as the inverse of as.dendrogram():
> stopifnot(identical(as.hclust(dend1)[1:4], hc[1:4]))
> 
> dend2 <- cut(dend1, h = 70)
> ## leaves are wrong horizontally in R 4.0 and earlier:
> plot(dend2$upper)
> plot(dend2$upper, nodePar = list(pch = c(1,7), col = 2:1))
> ##  dend2$lower is *NOT* a dendrogram, but a list of .. :
> plot(dend2$lower[[3]], nodePar = list(col = 4), horiz = TRUE, type = "tr")
> ## "inner" and "leaf" edges in different type & color :
> plot(dend2$lower[[2]], nodePar = list(col = 1),   # non empty list
+      edgePar = list(lty = 1:2, col = 2:1), edge.root = TRUE)
> par(op)
> d3 <- dend2$lower[[2]][[2]][[1]]
> stopifnot(identical(d3, dend2$lower[[2]][[c(2,1)]]))
> str(d3, last.str = "'")
--[dendrogram w/ 2 branches and 7 members at h = 26.4]
  |--[dendrogram w/ 2 branches and 3 members at h = 16.9]
  |  |--leaf "Delaware" 
  |  '--[dendrogram w/ 2 branches and 2 members at h = 15.5]
  |     |--leaf "Alabama" 
  |     '--leaf "Louisiana" 
  '--[dendrogram w/ 2 branches and 4 members at h = 18.4]
     |--[dendrogram w/ 2 branches and 2 members at h = 6.24]
     |  |--leaf "Illinois" 
     |  '--leaf "New York" 
     '--[dendrogram w/ 2 branches and 2 members at h = 13.3]
        |--leaf "Michigan" 
        '--leaf "Nevada" 
> 
> ## to peek at the inner structure "if you must", use '[..]' indexing :
> str(d3[2][[1]]) ## or the full
List of 2
 $ :List of 2
  ..$ : int 13
  .. ..- attr(*, "label")= chr "Illinois"
  .. ..- attr(*, "members")= int 1
  .. ..- attr(*, "height")= num 0
  .. ..- attr(*, "leaf")= logi TRUE
  ..$ : int 32
  .. ..- attr(*, "label")= chr "New York"
  .. ..- attr(*, "members")= int 1
  .. ..- attr(*, "height")= num 0
  .. ..- attr(*, "leaf")= logi TRUE
  ..- attr(*, "members")= int 2
  ..- attr(*, "midpoint")= num 0.5
  ..- attr(*, "height")= num 6.24
 $ :List of 2
  ..$ : int 22
  .. ..- attr(*, "label")= chr "Michigan"
  .. ..- attr(*, "members")= int 1
  .. ..- attr(*, "height")= num 0
  .. ..- attr(*, "leaf")= logi TRUE
  ..$ : int 28
  .. ..- attr(*, "label")= chr "Nevada"
  .. ..- attr(*, "members")= int 1
  .. ..- attr(*, "height")= num 0
  .. ..- attr(*, "leaf")= logi TRUE
  ..- attr(*, "members")= int 2
  ..- attr(*, "midpoint")= num 0.5
  ..- attr(*, "height")= num 13.3
 - attr(*, "members")= int 4
 - attr(*, "midpoint")= num 1.5
 - attr(*, "height")= num 18.4
> str(d3[])
List of 2
 $ :List of 2
  ..$ : int 8
  .. ..- attr(*, "members")= int 1
  .. ..- attr(*, "height")= num 0
  .. ..- attr(*, "label")= chr "Delaware"
  .. ..- attr(*, "leaf")= logi TRUE
  ..$ :List of 2
  .. ..$ : int 1
  .. .. ..- attr(*, "label")= chr "Alabama"
  .. .. ..- attr(*, "members")= int 1
  .. .. ..- attr(*, "height")= num 0
  .. .. ..- attr(*, "leaf")= logi TRUE
  .. ..$ : int 18
  .. .. ..- attr(*, "label")= chr "Louisiana"
  .. .. ..- attr(*, "members")= int 1
  .. .. ..- attr(*, "height")= num 0
  .. .. ..- attr(*, "leaf")= logi TRUE
  .. ..- attr(*, "members")= int 2
  .. ..- attr(*, "midpoint")= num 0.5
  .. ..- attr(*, "height")= num 15.5
  ..- attr(*, "members")= int 3
  ..- attr(*, "midpoint")= num 0.75
  ..- attr(*, "height")= num 16.9
 $ :List of 2
  ..$ :List of 2
  .. ..$ : int 13
  .. .. ..- attr(*, "label")= chr "Illinois"
  .. .. ..- attr(*, "members")= int 1
  .. .. ..- attr(*, "height")= num 0
  .. .. ..- attr(*, "leaf")= logi TRUE
  .. ..$ : int 32
  .. .. ..- attr(*, "label")= chr "New York"
  .. .. ..- attr(*, "members")= int 1
  .. .. ..- attr(*, "height")= num 0
  .. .. ..- attr(*, "leaf")= logi TRUE
  .. ..- attr(*, "members")= int 2
  .. ..- attr(*, "midpoint")= num 0.5
  .. ..- attr(*, "height")= num 6.24
  ..$ :List of 2
  .. ..$ : int 22
  .. .. ..- attr(*, "label")= chr "Michigan"
  .. .. ..- attr(*, "members")= int 1
  .. .. ..- attr(*, "height")= num 0
  .. .. ..- attr(*, "leaf")= logi TRUE
  .. ..$ : int 28
  .. .. ..- attr(*, "label")= chr "Nevada"
  .. .. ..- attr(*, "members")= int 1
  .. .. ..- attr(*, "height")= num 0
  .. .. ..- attr(*, "leaf")= logi TRUE
  .. ..- attr(*, "members")= int 2
  .. ..- attr(*, "midpoint")= num 0.5
  .. ..- attr(*, "height")= num 13.3
  ..- attr(*, "members")= int 4
  ..- attr(*, "midpoint")= num 1.5
  ..- attr(*, "height")= num 18.4
 - attr(*, "members")= int 7
 - attr(*, "midpoint")= num 2.62
 - attr(*, "height")= num 26.4
> 
> ## merge() to join dendrograms:
> (d13 <- merge(dend2$lower[[1]], dend2$lower[[3]]))
'dendrogram' with 2 branches and 16 members total, at height 49.32173 
> ## merge() all parts back (using default 'height' instead of original one):
> den.1 <- Reduce(merge, dend2$lower)
> ## or merge() all four parts at same height --> 4 branches (!)
> d. <- merge(dend2$lower[[1]], dend2$lower[[2]], dend2$lower[[3]],
+             dend2$lower[[4]])
> ## (with a warning) or the same using  do.call :
> stopifnot(identical(d., do.call(merge, dend2$lower)))
> plot(d., main = "merge(d1, d2, d3, d4)  |->  dendrogram with a 4-split")
> 
> ## "Zoom" in to the first dendrogram :
> plot(dend1, xlim = c(1,20), ylim = c(1,50))
> 
> nP <- list(col = 3:2, cex = c(2.0, 0.75), pch =  21:22,
+            bg =  c("light blue", "pink"),
+            lab.cex = 0.75, lab.col = "tomato")
> plot(d3, nodePar= nP, edgePar = list(col = "gray", lwd = 2), horiz = TRUE)
> addE <- function(n) {
+       if(!is.leaf(n)) {
+         attr(n, "edgePar") <- list(p.col = "plum")
+         attr(n, "edgetext") <- paste(attr(n,"members"),"members")
+       }
+       n
+ }
> d3e <- dendrapply(d3, addE)
> plot(d3e, nodePar =  nP)
> plot(d3e, nodePar =  nP, leaflab = "textlike")
> 
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("density")
> ### * density
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: density
> ### Title: Kernel Density Estimation
> ### Aliases: density density.default
> ### Keywords: distribution smooth
> 
> ### ** Examples
> 
> require(graphics)
> 
> plot(density(c(-20, rep(0,98), 20)), xlim = c(-4, 4))  # IQR = 0
> 
> # The Old Faithful geyser data
> d <- density(faithful$eruptions, bw = "sj")
> d

Call:
	density.default(x = faithful$eruptions, bw = "sj")

Data: faithful$eruptions (272 obs.);	Bandwidth 'bw' = 0.14

       x               y            
 Min.   :1.180   Min.   :0.0001834  
 1st Qu.:2.265   1st Qu.:0.0422638  
 Median :3.350   Median :0.1709243  
 Mean   :3.350   Mean   :0.2301726  
 3rd Qu.:4.435   3rd Qu.:0.4134348  
 Max.   :5.520   Max.   :0.5945634  
> plot(d)
> 
> plot(d, type = "n")
> polygon(d, col = "wheat")
> 
> ## Missing values:
> x <- xx <- faithful$eruptions
> x[i.out <- sample(length(x), 10)] <- NA
> doR <- density(x, bw = 0.15, na.rm = TRUE)
> lines(doR, col = "blue")
> points(xx[i.out], rep(0.01, 10))
> 
> ## Weighted observations:
> fe <- sort(faithful$eruptions) # has quite a few non-unique values
> ## use 'counts / n' as weights:
> dw <- density(unique(fe), weights = table(fe)/length(fe), bw = d$bw)
> utils::str(dw) ## smaller n: only 126, but identical estimate:
List of 7
 $ x        : num [1:512] 1.18 1.19 1.2 1.21 1.21 ...
 $ y        : num [1:512] 0.000183 0.000223 0.00027 0.000328 0.000397 ...
 $ bw       : num 0.14
 $ n        : int 126
 $ call     : language density.default(x = unique(fe), bw = d$bw, weights = table(fe)/length(fe))
 $ data.name: chr "unique(fe)"
 $ has.na   : logi FALSE
 - attr(*, "class")= chr "density"
> stopifnot(all.equal(d[1:3], dw[1:3]))
> 
> ## simulation from a density() fit:
> # a kernel density fit is an equally-weighted mixture.
> fit <- density(xx)
> N <- 1e6
> x.new <- rnorm(N, sample(xx, size = N, replace = TRUE), fit$bw)
> plot(fit)
> lines(density(x.new), col = "blue")
> 
> 
> (kernels <- eval(formals(density.default)$kernel))
[1] "gaussian"     "epanechnikov" "rectangular"  "triangular"   "biweight"    
[6] "cosine"       "optcosine"   
> 
> ## show the kernels in the R parametrization
> plot (density(0, bw = 1), xlab = "",
+       main = "R's density() kernels with bw = 1")
> for(i in 2:length(kernels))
+    lines(density(0, bw = 1, kernel =  kernels[i]), col = i)
> legend(1.5,.4, legend = kernels, col = seq(kernels),
+        lty = 1, cex = .8, y.intersp = 1)
> 
> ## show the kernels in the S parametrization
> plot(density(0, from = -1.2, to = 1.2, width = 2, kernel = "gaussian"),
+      type = "l", ylim = c(0, 1), xlab = "",
+      main = "R's density() kernels with width = 1")
> for(i in 2:length(kernels))
+    lines(density(0, width = 2, kernel =  kernels[i]), col = i)
> legend(0.6, 1.0, legend = kernels, col = seq(kernels), lty = 1)
> 
> ##-------- Semi-advanced theoretic from here on -------------
> 
> (RKs <- cbind(sapply(kernels,
+                      function(k) density(kernel = k, give.Rkern = TRUE))))
                  [,1]
gaussian     0.2820948
epanechnikov 0.2683282
rectangular  0.2886751
triangular   0.2721655
biweight     0.2699746
cosine       0.2711340
optcosine    0.2684756
> 100*round(RKs["epanechnikov",]/RKs, 4) ## Efficiencies
               [,1]
gaussian      95.12
epanechnikov 100.00
rectangular   92.95
triangular    98.59
biweight      99.39
cosine        98.97
optcosine     99.95
> 
> bw <- bw.SJ(precip) ## sensible automatic choice
> plot(density(precip, bw = bw),
+      main = "same sd bandwidths, 7 different kernels")
> for(i in 2:length(kernels))
+    lines(density(precip, bw = bw, kernel = kernels[i]), col = i)
> 
> ## Bandwidth Adjustment for "Exactly Equivalent Kernels"
> h.f <- sapply(kernels, function(k)density(kernel = k, give.Rkern = TRUE))
> (h.f <- (h.f["gaussian"] / h.f)^ .2)
    gaussian epanechnikov  rectangular   triangular     biweight       cosine 
   1.0000000    1.0100567    0.9953989    1.0071923    1.0088217    1.0079575 
   optcosine 
   1.0099458 
> ## -> 1, 1.01, .995, 1.007,... close to 1 => adjustment barely visible..
> 
> plot(density(precip, bw = bw),
+      main = "equivalent bandwidths, 7 different kernels")
> for(i in 2:length(kernels))
+    lines(density(precip, bw = bw, adjust = h.f[i], kernel = kernels[i]),
+          col = i)
> legend(55, 0.035, legend = kernels, col = seq(kernels), lty = 1)
> 
> 
> 
> cleanEx()
> nameEx("deriv")
> ### * deriv
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: deriv
> ### Title: Symbolic and Algorithmic Derivatives of Simple Expressions
> ### Aliases: D deriv deriv.default deriv.formula deriv3 deriv3.default
> ###   deriv3.formula
> ### Keywords: math nonlinear
> 
> ### ** Examples
> 
> ## formula argument :
> dx2x <- deriv(~ x^2, "x") ; dx2x
expression({
    .value <- x^2
    .grad <- array(0, c(length(.value), 1L), list(NULL, c("x")))
    .grad[, "x"] <- 2 * x
    attr(.value, "gradient") <- .grad
    .value
})
> ## Not run: 
> ##D expression({
> ##D          .value <- x^2
> ##D          .grad <- array(0, c(length(.value), 1), list(NULL, c("x")))
> ##D          .grad[, "x"] <- 2 * x
> ##D          attr(.value, "gradient") <- .grad
> ##D          .value
> ##D })
> ## End(Not run)
> mode(dx2x)
[1] "expression"
> x <- -1:2
> eval(dx2x)
[1] 1 0 1 4
attr(,"gradient")
      x
[1,] -2
[2,]  0
[3,]  2
[4,]  4
> 
> ## Something 'tougher':
> trig.exp <- expression(sin(cos(x + y^2)))
> ( D.sc <- D(trig.exp, "x") )
-(cos(cos(x + y^2)) * sin(x + y^2))
> all.equal(D(trig.exp[[1]], "x"), D.sc)
[1] TRUE
> 
> ( dxy <- deriv(trig.exp, c("x", "y")) )
expression({
    .expr2 <- x + y^2
    .expr3 <- cos(.expr2)
    .expr5 <- cos(.expr3)
    .expr6 <- sin(.expr2)
    .value <- sin(.expr3)
    .grad <- array(0, c(length(.value), 2L), list(NULL, c("x", 
        "y")))
    .grad[, "x"] <- -(.expr5 * .expr6)
    .grad[, "y"] <- -(.expr5 * (.expr6 * (2 * y)))
    attr(.value, "gradient") <- .grad
    .value
})
> y <- 1
> eval(dxy)
[1]  0.8414710  0.5143953 -0.4042392 -0.8360219
attr(,"gradient")
              x         y
[1,]  0.0000000  0.000000
[2,] -0.7216061 -1.443212
[3,] -0.8316919 -1.663384
[4,] -0.0774320 -0.154864
> eval(D.sc)
[1]  0.0000000 -0.7216061 -0.8316919 -0.0774320
> 
> ## function returned:
> deriv((y ~ sin(cos(x) * y)), c("x","y"), function.arg = TRUE)
function (x, y) 
{
    .expr1 <- cos(x)
    .expr2 <- .expr1 * y
    .expr4 <- cos(.expr2)
    .value <- sin(.expr2)
    .grad <- array(0, c(length(.value), 2L), list(NULL, c("x", 
        "y")))
    .grad[, "x"] <- -(.expr4 * (sin(x) * y))
    .grad[, "y"] <- .expr4 * .expr1
    attr(.value, "gradient") <- .grad
    .value
}
> 
> ## function with defaulted arguments:
> (fx <- deriv(y ~ b0 + b1 * 2^(-x/th), c("b0", "b1", "th"),
+              function(b0, b1, th, x = 1:7){} ) )
function (b0, b1, th, x = 1:7) 
{
    .expr3 <- 2^(-x/th)
    .value <- b0 + b1 * .expr3
    .grad <- array(0, c(length(.value), 3L), list(NULL, c("b0", 
        "b1", "th")))
    .grad[, "b0"] <- 1
    .grad[, "b1"] <- .expr3
    .grad[, "th"] <- b1 * (.expr3 * (log(2) * (x/th^2)))
    attr(.value, "gradient") <- .grad
    .value
}
> fx(2, 3, 4)
[1] 4.522689 4.121320 3.783811 3.500000 3.261345 3.060660 2.891905
attr(,"gradient")
     b0        b1        th
[1,]  1 0.8408964 0.1092872
[2,]  1 0.7071068 0.1837984
[3,]  1 0.5946036 0.2318331
[4,]  1 0.5000000 0.2599302
[5,]  1 0.4204482 0.2732180
[6,]  1 0.3535534 0.2756976
[7,]  1 0.2973018 0.2704720
> 
> ## First derivative
> 
> D(expression(x^2), "x")
2 * x
> stopifnot(D(as.name("x"), "x") == 1)
> 
> ## Higher derivatives
> deriv3(y ~ b0 + b1 * 2^(-x/th), c("b0", "b1", "th"),
+      c("b0", "b1", "th", "x") )
function (b0, b1, th, x) 
{
    .expr3 <- 2^(-x/th)
    .expr6 <- log(2)
    .expr7 <- th^2
    .expr9 <- .expr6 * (x/.expr7)
    .expr10 <- .expr3 * .expr9
    .value <- b0 + b1 * .expr3
    .grad <- array(0, c(length(.value), 3L), list(NULL, c("b0", 
        "b1", "th")))
    .hessian <- array(0, c(length(.value), 3L, 3L), list(NULL, 
        c("b0", "b1", "th"), c("b0", "b1", "th")))
    .grad[, "b0"] <- 1
    .grad[, "b1"] <- .expr3
    .hessian[, "b1", "b1"] <- 0
    .hessian[, "b1", "th"] <- .hessian[, "th", "b1"] <- .expr10
    .grad[, "th"] <- b1 * .expr10
    .hessian[, "th", "th"] <- b1 * (.expr10 * .expr9 - .expr3 * 
        (.expr6 * (x * (2 * th)/.expr7^2)))
    attr(.value, "gradient") <- .grad
    attr(.value, "hessian") <- .hessian
    .value
}
> 
> ## Higher derivatives:
> DD <- function(expr, name, order = 1) {
+    if(order < 1) stop("'order' must be >= 1")
+    if(order == 1) D(expr, name)
+    else DD(D(expr, name), name, order - 1)
+ }
> DD(expression(sin(x^2)), "x", 3)
-(sin(x^2) * (2 * x) * 2 + ((cos(x^2) * (2 * x) * (2 * x) + sin(x^2) * 
    2) * (2 * x) + sin(x^2) * (2 * x) * 2))
> ## showing the limits of the internal "simplify()" :
> ## Not run: 
> ##D -sin(x^2) * (2 * x) * 2 + ((cos(x^2) * (2 * x) * (2 * x) + sin(x^2) *
> ##D     2) * (2 * x) + sin(x^2) * (2 * x) * 2)
> ## End(Not run)
> 
> ## New (R 3.4.0, 2017):
> D(quote(log1p(x^2)), "x") ## log1p(x) = log(1 + x)
2 * x/(1 + x^2)
> stopifnot(identical(
+        D(quote(log1p(x^2)), "x"),
+        D(quote(log(1+x^2)), "x")))
> D(quote(expm1(x^2)), "x") ## expm1(x) = exp(x) - 1
exp(x^2) * (2 * x)
> stopifnot(identical(
+        D(quote(expm1(x^2)), "x") -> Dex1,
+        D(quote(exp(x^2)-1), "x")),
+        identical(Dex1, quote(exp(x^2) * (2 * x))))
> 
> D(quote(sinpi(x^2)), "x") ## sinpi(x) = sin(pi*x)
cospi(x^2) * (pi * (2 * x))
> D(quote(cospi(x^2)), "x") ## cospi(x) = cos(pi*x)
-(sinpi(x^2) * (pi * (2 * x)))
> D(quote(tanpi(x^2)), "x") ## tanpi(x) = tan(pi*x)
pi * (2 * x)/cospi(x^2)^2
> 
> stopifnot(identical(D(quote(log2 (x^2)), "x"),
+                     quote(2 * x/(x^2 * log(2)))),
+           identical(D(quote(log10(x^2)), "x"),
+                     quote(2 * x/(x^2 * log(10)))))
> 
> 
> 
> 
> cleanEx()
> nameEx("diffinv")
> ### * diffinv
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: diffinv
> ### Title: Discrete Integration: Inverse of Differencing
> ### Aliases: diffinv diffinv.default diffinv.ts
> ### Keywords: ts
> 
> ### ** Examples
> 
> s <- 1:10
> d <- diff(s)
> diffinv(d, xi = 1)
 [1]  1  2  3  4  5  6  7  8  9 10
> 
> 
> 
> cleanEx()
> nameEx("dist")
> ### * dist
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: dist
> ### Title: Distance Matrix Computation
> ### Aliases: dist print.dist format.dist labels.dist as.matrix.dist as.dist
> ###   as.dist.default
> ### Keywords: multivariate cluster
> 
> ### ** Examples
> 
> require(graphics)
> 
> x <- matrix(rnorm(100), nrow = 5)
> dist(x)
         1        2        3        4
2 5.701817                           
3 6.013119 5.032069                  
4 7.276905 5.325473 5.811861         
5 6.619295 5.306750 4.945987 6.612081
> dist(x, diag = TRUE)
         1        2        3        4        5
1 0.000000                                    
2 5.701817 0.000000                           
3 6.013119 5.032069 0.000000                  
4 7.276905 5.325473 5.811861 0.000000         
5 6.619295 5.306750 4.945987 6.612081 0.000000
> dist(x, upper = TRUE)
         1        2        3        4        5
1          5.701817 6.013119 7.276905 6.619295
2 5.701817          5.032069 5.325473 5.306750
3 6.013119 5.032069          5.811861 4.945987
4 7.276905 5.325473 5.811861          6.612081
5 6.619295 5.306750 4.945987 6.612081         
> m <- as.matrix(dist(x))
> d <- as.dist(m)
> stopifnot(d == dist(x))
> 
> ## Use correlations between variables "as distance"
> dd <- as.dist((1 - cor(USJudgeRatings))/2)
> round(1000 * dd) # (prints more nicely)
     CONT INTG DMNR DILG CFMG DECI PREP FAMI ORAL WRIT PHYS
INTG  567                                                  
DMNR  577   18                                             
DILG  494   64   82                                        
CFMG  432   93   93   21                                   
DECI  457   99   98   22    9                              
PREP  494   61   72   11   21   21                         
FAMI  513   66   79   21   32   29    5                    
ORAL  506   44   47   23   25   26    8    9               
WRIT  522   46   53   20   29   27    7    5    3          
PHYS  473  129  106   94   60   64   76   78   54   72     
RTEN  517   31   28   35   36   38   25   29    9   16   47
> plot(hclust(dd)) # to see a dendrogram of clustered variables
> 
> ## example of binary and canberra distances.
> x <- c(0, 0, 1, 1, 1, 1)
> y <- c(1, 0, 1, 1, 0, 1)
> dist(rbind(x, y), method = "binary")
    x
y 0.4
> ## answer 0.4 = 2/5
> dist(rbind(x, y), method = "canberra")
    x
y 2.4
> ## answer 2 * (6/5)
> 
> ## To find the names
> labels(eurodist)
 [1] "Athens"          "Barcelona"       "Brussels"        "Calais"         
 [5] "Cherbourg"       "Cologne"         "Copenhagen"      "Geneva"         
 [9] "Gibraltar"       "Hamburg"         "Hook of Holland" "Lisbon"         
[13] "Lyons"           "Madrid"          "Marseilles"      "Milan"          
[17] "Munich"          "Paris"           "Rome"            "Stockholm"      
[21] "Vienna"         
> 
> ## Examples involving "Inf" :
> ## 1)
> x[6] <- Inf
> (m2 <- rbind(x, y))
  [,1] [,2] [,3] [,4] [,5] [,6]
x    0    0    1    1    1  Inf
y    1    0    1    1    0    1
> dist(m2, method = "binary")   # warning, answer 0.5 = 2/4
Warning in dist(m2, method = "binary") :
  treating non-finite values as NA
    x
y 0.5
> ## These all give "Inf":
> stopifnot(Inf == dist(m2, method =  "euclidean"),
+           Inf == dist(m2, method =  "maximum"),
+           Inf == dist(m2, method =  "manhattan"))
> ##  "Inf" is same as very large number:
> x1 <- x; x1[6] <- 1e100
> stopifnot(dist(cbind(x, y), method = "canberra") ==
+     print(dist(cbind(x1, y), method = "canberra")))
  1 2 3 4 5
2 2        
3 1 2      
4 1 2 0    
5 2 2 1 1  
6 1 2 1 1 2
> 
> ## 2)
> y[6] <- Inf #-> 6-th pair is excluded
> dist(rbind(x, y), method = "binary"  )   # warning; 0.5
Warning in dist(rbind(x, y), method = "binary") :
  treating non-finite values as NA
    x
y 0.5
> dist(rbind(x, y), method = "canberra"  ) # 3
  x
y 3
> dist(rbind(x, y), method = "maximum")    # 1
  x
y 1
> dist(rbind(x, y), method = "manhattan")  # 2.4
    x
y 2.4
> 
> 
> 
> cleanEx()
> nameEx("dummy.coef")
> ### * dummy.coef
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: dummy.coef
> ### Title: Extract Coefficients in Original Coding
> ### Aliases: dummy.coef dummy.coef.lm dummy.coef.aovlist
> ### Keywords: models
> 
> ### ** Examples
> 
> options(contrasts = c("contr.helmert", "contr.poly"))
> ## From Venables and Ripley (2002) p.165.
> npk.aov <- aov(yield ~ block + N*P*K, npk)
> dummy.coef(npk.aov)
Full coefficients are 
                                                                               
(Intercept):        54.875                                                     
block:                   1          2          3          4      5      6      
                    -0.850      2.575      5.900     -4.750 -4.350  1.475      
N:                       0          1                                          
                 -2.808333   2.808333                                          
P:                       0          1                                          
                 0.5916667 -0.5916667                                          
K:                       0          1                                          
                  1.991667  -1.991667                                          
N:P:                   0:0        1:0        0:1        1:1                    
                -0.9416667  0.9416667  0.9416667 -0.9416667                    
N:K:                   0:0        1:0        0:1        1:1                    
                    -1.175      1.175      1.175     -1.175                    
P:K:                   0:0        1:0        0:1        1:1                    
                 0.1416667 -0.1416667 -0.1416667  0.1416667                    
N:P:K:               0:0:0      1:0:0      0:1:0      1:1:0  0:0:1  1:0:1 0:1:1
                         0          0          0          0      0      0     0
                     
(Intercept):         
block:               
                     
N:                   
                     
P:                   
                     
K:                   
                     
N:P:                 
                     
N:K:                 
                     
P:K:                 
                     
N:P:K:          1:1:1
                    0
> 
> npk.aovE <- aov(yield ~  N*P*K + Error(block), npk)
> dummy.coef(npk.aovE)

     Error: (Intercept) 
                      
(Intercept):    54.875

     Error: block 
                                                                               
N:P:K:        0:0:0     1:0:0     0:1:0     1:1:0     0:0:1     1:0:1     0:1:1
          -1.241667  1.241667  1.241667 -1.241667  1.241667 -1.241667 -1.241667
                   
N:P:K:        1:1:1
           1.241667

     Error: Within 
                                                   
N:               0          1                      
         -2.808333   2.808333                      
P:               0          1                      
         0.5916667 -0.5916667                      
K:               0          1                      
          1.991667  -1.991667                      
N:P:           0:0        1:0        0:1        1:1
        -0.9416667  0.9416667  0.9416667 -0.9416667
N:K:           0:0        1:0        0:1        1:1
            -1.175      1.175      1.175     -1.175
P:K:           0:0        1:0        0:1        1:1
         0.1416667 -0.1416667 -0.1416667  0.1416667
> 
> 
> 
> base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
> cleanEx()
> nameEx("ecdf")
> ### * ecdf
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ecdf
> ### Title: Empirical Cumulative Distribution Function
> ### Aliases: ecdf plot.ecdf print.ecdf summary.ecdf quantile.ecdf
> ### Keywords: dplot hplot
> 
> ### ** Examples
> 
> ##-- Simple didactical  ecdf  example :
> x <- rnorm(12)
> Fn <- ecdf(x)
> Fn     # a *function*
Empirical CDF 
Call: ecdf(x)
 x[1:12] = -0.83563, -0.82047, -0.62645,  ..., 1.5118, 1.5953
> Fn(x)  # returns the percentiles for x
 [1] 0.25000000 0.41666667 0.08333333 1.00000000 0.50000000 0.16666667
 [7] 0.66666667 0.83333333 0.75000000 0.33333333 0.91666667 0.58333333
> tt <- seq(-2, 2, by = 0.1)
> 12 * Fn(tt) # Fn is a 'simple' function {with values k/12}
 [1]  0  0  0  0  0  0  0  0  0  0  0  0  2  2  3  3  3  4  4  4  4  4  5  5  7
[26]  8  9  9 10 10 10 10 10 10 10 10 12 12 12 12 12
> summary(Fn)
Empirical CDF:	  12 unique values with summary
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
-0.8356 -0.3857  0.3597  0.2686  0.6164  1.5953 
> ##--> see below for graphics
> knots(Fn)  # the unique data values {12 of them if there were no ties}
 [1] -0.8356286 -0.8204684 -0.6264538 -0.3053884  0.1836433  0.3295078
 [7]  0.3898432  0.4874291  0.5757814  0.7383247  1.5117812  1.5952808
> 
> y <- round(rnorm(12), 1); y[3] <- y[1]
> Fn12 <- ecdf(y)
> Fn12
Empirical CDF 
Call: ecdf(y)
 x[1:8] =   -2.2,     -2,   -0.6,  ...,    0.8,    0.9
> knots(Fn12) # unique values (always less than 12!)
[1] -2.2 -2.0 -0.6  0.0  0.1  0.6  0.8  0.9
> summary(Fn12)
Empirical CDF:	  8 unique values with summary
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  -2.20   -0.95    0.05   -0.30    0.65    0.90 
> summary.stepfun(Fn12)
Step function with continuity 'f'= 0 ,  8 knots with summary
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  -2.20   -0.95    0.05   -0.30    0.65    0.90 

and	9 plateau levels (y) with summary
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
 0.0000  0.1667  0.5000  0.4630  0.6667  1.0000 
> 
> ## Advanced: What's inside the function closure?
> ls(environment(Fn12))
[1] "f"      "method" "na.rm"  "nobs"   "x"      "y"      "yleft"  "yright"
> ## "f"     "method" "na.rm"  "nobs"   "x"     "y"    "yleft"  "yright"
> utils::ls.str(environment(Fn12))
f :  num 0
method :  int 2
na.rm :  logi TRUE
nobs :  int 12
x :  num [1:8] -2.2 -2 -0.6 0 0.1 0.6 0.8 0.9
y :  num [1:8] 0.0833 0.1667 0.3333 0.5 0.5833 ...
yleft :  num 0
yright :  num 1
> stopifnot(all.equal(quantile(Fn12), quantile(y)))
> 
> ###----------------- Plotting --------------------------
> require(graphics)
> 
> op <- par(mfrow = c(3, 1), mgp = c(1.5, 0.8, 0), mar =  .1+c(3,3,2,1))
> 
> F10 <- ecdf(rnorm(10))
> summary(F10)
Empirical CDF:	  10 unique values with summary
    Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
-1.47075 -0.14254 -0.05497  0.04667  0.41037  1.35868 
> 
> plot(F10)
> plot(F10, verticals = TRUE, do.points = FALSE)
> 
> plot(Fn12 , lwd = 2) ; mtext("lwd = 2", adj = 1)
> xx <- unique(sort(c(seq(-3, 2, length.out = 201), knots(Fn12))))
> lines(xx, Fn12(xx), col = "blue")
> abline(v = knots(Fn12), lty = 2, col = "gray70")
> 
> plot(xx, Fn12(xx), type = "o", cex = .1)  #- plot.default {ugly}
> plot(Fn12, col.hor = "red", add =  TRUE)  #- plot method
> abline(v = knots(Fn12), lty = 2, col = "gray70")
> ## luxury plot
> plot(Fn12, verticals = TRUE, col.points = "blue",
+      col.hor = "red", col.vert = "bisque")
> 
> ##-- this works too (automatic call to  ecdf(.)):
> plot.ecdf(rnorm(24))
> title("via  simple  plot.ecdf(x)", adj = 1)
> 
> par(op)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("eff.aovlist")
> ### * eff.aovlist
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: eff.aovlist
> ### Title: Compute Efficiencies of Multistratum Analysis of Variance
> ### Aliases: eff.aovlist
> ### Keywords: models
> 
> ### ** Examples
> 
> ## An example from Yates (1932),
> ## a 2^3 design in 2 blocks replicated 4 times
> 
> Block <- gl(8, 4)
> A <- factor(c(0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,
+               0,1,0,1,0,1,0,1,0,1,0,1))
> B <- factor(c(0,0,1,1,0,0,1,1,0,1,0,1,1,0,1,0,0,0,1,1,
+               0,0,1,1,0,0,1,1,0,0,1,1))
> C <- factor(c(0,1,1,0,1,0,0,1,0,0,1,1,0,0,1,1,0,1,0,1,
+               1,0,1,0,0,0,1,1,1,1,0,0))
> Yield <- c(101, 373, 398, 291, 312, 106, 265, 450, 106, 306, 324, 449,
+            272, 89, 407, 338, 87, 324, 279, 471, 323, 128, 423, 334,
+            131, 103, 445, 437, 324, 361, 302, 272)
> aovdat <- data.frame(Block, A, B, C, Yield)
> 
> old <- getOption("contrasts")
> options(contrasts = c("contr.helmert", "contr.poly"))
> ## IGNORE_RDIFF_BEGIN
> (fit <- aov(Yield ~ A*B*C + Error(Block), data = aovdat))

Call:
aov(formula = Yield ~ A * B * C + Error(Block), data = aovdat)

Grand Mean: 291.5938

Stratum 1: Block

Terms:
                      A:B       A:C       B:C     A:B:C Residuals
Sum of Squares   780.1250  276.1250 2556.1250  112.5000  774.0938
Deg. of Freedom         1         1         1         1         3

Residual standard error: 16.06335
Estimated effects are balanced

Stratum 2: Within

Terms:
                        A         B         C       A:B       A:C       B:C
Sum of Squares    3465.28 161170.03 278817.78     28.17   1802.67  11528.17
Deg. of Freedom         1         1         1         1         1         1
                    A:B:C Residuals
Sum of Squares      45.37   5423.28
Deg. of Freedom         1        17

Residual standard error: 17.86103
Estimated effects are balanced
> ## IGNORE_RDIFF_END
> eff.aovlist(fit)
       A B C  A:B  A:C  B:C A:B:C
Block  0 0 0 0.25 0.25 0.25  0.25
Within 1 1 1 0.75 0.75 0.75  0.75
> options(contrasts = old)
> 
> 
> 
> base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
> cleanEx()
> nameEx("effects")
> ### * effects
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: effects
> ### Title: Effects from Fitted Model
> ### Aliases: effects effects.lm effects.glm
> ### Keywords: models regression
> 
> ### ** Examples
> 
> y <- c(1:3, 7, 5)
> x <- c(1:3, 6:7)
> ( ee <- effects(lm(y ~ x)) )
(Intercept)           x                                     
 -8.0498447   4.3655709   0.1483334   1.6144112  -1.2302295 
attr(,"assign")
[1] 0 1
attr(,"class")
[1] "coef"
> c( round(ee - effects(lm(y+10 ~ I(x-3.8))), 3) )
(Intercept)           x                                     
     22.361       0.000       0.000       0.000       0.000 
> # just the first is different
> 
> 
> 
> cleanEx()
> nameEx("embed")
> ### * embed
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: embed
> ### Title: Embedding a Time Series
> ### Aliases: embed
> ### Keywords: ts
> 
> ### ** Examples
> 
> x <- 1:10
> embed (x, 3)
     [,1] [,2] [,3]
[1,]    3    2    1
[2,]    4    3    2
[3,]    5    4    3
[4,]    6    5    4
[5,]    7    6    5
[6,]    8    7    6
[7,]    9    8    7
[8,]   10    9    8
> 
> 
> 
> cleanEx()
> nameEx("expand.model.frame")
> ### * expand.model.frame
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: expand.model.frame
> ### Title: Add new variables to a model frame
> ### Aliases: expand.model.frame
> ### Keywords: manip regression
> 
> ### ** Examples
> 
> model <- lm(log(Volume) ~ log(Girth) + log(Height), data = trees)
> expand.model.frame(model, ~ Girth) # prints data.frame like
   log(Volume) log(Girth) log(Height) Girth
1     2.332144   2.116256    4.248495   8.3
2     2.332144   2.151762    4.174387   8.6
3     2.322388   2.174752    4.143135   8.8
4     2.797281   2.351375    4.276666  10.5
5     2.933857   2.370244    4.394449  10.7
6     2.980619   2.379546    4.418841  10.8
7     2.747271   2.397895    4.189655  11.0
8     2.901422   2.397895    4.317488  11.0
9     3.117950   2.406945    4.382027  11.1
10    2.990720   2.415914    4.317488  11.2
11    3.186353   2.424803    4.369448  11.3
12    3.044522   2.433613    4.330733  11.4
13    3.063391   2.433613    4.330733  11.4
14    3.058707   2.459589    4.234107  11.7
15    2.949688   2.484907    4.317488  12.0
16    3.100092   2.557227    4.304065  12.9
17    3.520461   2.557227    4.442651  12.9
18    3.310543   2.587764    4.454347  13.3
19    3.246491   2.617396    4.262680  13.7
20    3.214868   2.624669    4.158883  13.8
21    3.540959   2.639057    4.356709  14.0
22    3.456317   2.653242    4.382027  14.2
23    3.591818   2.674149    4.304065  14.5
24    3.645450   2.772589    4.276666  16.0
25    3.751854   2.791165    4.343805  16.3
26    4.014580   2.850707    4.394449  17.3
27    4.019980   2.862201    4.406719  17.5
28    4.065602   2.884801    4.382027  17.9
29    3.941582   2.890372    4.382027  18.0
30    3.931826   2.890372    4.382027  18.0
31    4.343805   3.025291    4.465908  20.6
> 
> dd <- data.frame(x = 1:5, y = rnorm(5), z = c(1,2,NA,4,5))
> model <- glm(y ~ x, data = dd, subset = 1:4, na.action = na.omit)
> expand.model.frame(model, "z", na.expand = FALSE) # = default
           y x z
1 -0.6264538 1 1
2  0.1836433 2 2
4  1.5952808 4 4
> expand.model.frame(model, "z", na.expand = TRUE)
           y x  z
1 -0.6264538 1  1
2  0.1836433 2  2
3 -0.8356286 3 NA
4  1.5952808 4  4
> 
> 
> 
> cleanEx()
> nameEx("extractAIC")
> ### * extractAIC
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: extractAIC
> ### Title: Extract AIC from a Fitted Model
> ### Aliases: extractAIC
> ### Keywords: models
> 
> ### ** Examples
> 
> 
> cleanEx()
> nameEx("factanal")
> ### * factanal
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: factanal
> ### Title: Factor Analysis
> ### Aliases: factanal
> ### Keywords: multivariate
> 
> ### ** Examples
> 
> # A little demonstration, v2 is just v1 with noise,
> # and same for v4 vs. v3 and v6 vs. v5
> # Last four cases are there to add noise
> # and introduce a positive manifold (g factor)
> v1 <- c(1,1,1,1,1,1,1,1,1,1,3,3,3,3,3,4,5,6)
> v2 <- c(1,2,1,1,1,1,2,1,2,1,3,4,3,3,3,4,6,5)
> v3 <- c(3,3,3,3,3,1,1,1,1,1,1,1,1,1,1,5,4,6)
> v4 <- c(3,3,4,3,3,1,1,2,1,1,1,1,2,1,1,5,6,4)
> v5 <- c(1,1,1,1,1,3,3,3,3,3,1,1,1,1,1,6,4,5)
> v6 <- c(1,1,1,2,1,3,3,3,4,3,1,1,1,2,1,6,5,4)
> m1 <- cbind(v1,v2,v3,v4,v5,v6)
> cor(m1)
          v1        v2        v3        v4        v5        v6
v1 1.0000000 0.9393083 0.5128866 0.4320310 0.4664948 0.4086076
v2 0.9393083 1.0000000 0.4124441 0.4084281 0.4363925 0.4326113
v3 0.5128866 0.4124441 1.0000000 0.8770750 0.5128866 0.4320310
v4 0.4320310 0.4084281 0.8770750 1.0000000 0.4320310 0.4323259
v5 0.4664948 0.4363925 0.5128866 0.4320310 1.0000000 0.9473451
v6 0.4086076 0.4326113 0.4320310 0.4323259 0.9473451 1.0000000
> factanal(m1, factors = 3) # varimax is the default

Call:
factanal(x = m1, factors = 3)

Uniquenesses:
   v1    v2    v3    v4    v5    v6 
0.005 0.101 0.005 0.224 0.084 0.005 

Loadings:
   Factor1 Factor2 Factor3
v1 0.944   0.182   0.267  
v2 0.905   0.235   0.159  
v3 0.236   0.210   0.946  
v4 0.180   0.242   0.828  
v5 0.242   0.881   0.286  
v6 0.193   0.959   0.196  

               Factor1 Factor2 Factor3
SS loadings      1.893   1.886   1.797
Proportion Var   0.316   0.314   0.300
Cumulative Var   0.316   0.630   0.929

The degrees of freedom for the model is 0 and the fit was 0.4755 
> # The following shows the g factor as PC1
> 
> ## formula interface
> factanal(~v1+v2+v3+v4+v5+v6, factors = 3,
+          scores = "Bartlett")$scores
      Factor1    Factor2    Factor3
1  -0.9039949 -0.9308984  0.9475392
2  -0.8685952 -0.9328721  0.9352330
3  -0.9082818 -0.9320093  0.9616422
4  -1.0021975 -0.2529689  0.8178552
5  -0.9039949 -0.9308984  0.9475392
6  -0.7452711  0.7273960 -0.7884733
7  -0.7098714  0.7254223 -0.8007795
8  -0.7495580  0.7262851 -0.7743704
9  -0.8080740  1.4033517 -0.9304636
10 -0.7452711  0.7273960 -0.7884733
11  0.9272282 -0.9307506 -0.8371538
12  0.9626279 -0.9327243 -0.8494600
13  0.9229413 -0.9318615 -0.8230509
14  0.8290256 -0.2528211 -0.9668378
15  0.9272282 -0.9307506 -0.8371538
16  0.4224366  2.0453079  1.2864761
17  1.4713902  1.2947716  0.5451562
18  1.8822320  0.3086244  1.9547752
> 
> 
> 
> cleanEx()
> nameEx("factor.scope")
> ### * factor.scope
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: factor.scope
> ### Title: Compute Allowed Changes in Adding to or Dropping from a Formula
> ### Aliases: add.scope drop.scope factor.scope
> ### Keywords: models
> 
> ### ** Examples
> 
> add.scope( ~ a + b + c + a:b,  ~ (a + b + c)^3)
[1] "a:c" "b:c"
> # [1] "a:c" "b:c"
> drop.scope( ~ a + b + c + a:b)
[1] "c"   "a:b"
> # [1] "c"   "a:b"
> 
> 
> 
> cleanEx()
> nameEx("family")
> ### * family
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: family
> ### Title: Family Objects for Models
> ### Aliases: family binomial gaussian Gamma inverse.gaussian poisson quasi
> ###   quasibinomial quasipoisson
> ### Keywords: models
> 
> ### ** Examples
> 
> require(utils) # for str
> 
> nf <- gaussian()  # Normal family
> nf

Family: gaussian 
Link function: identity 

> str(nf)
List of 11
 $ family    : chr "gaussian"
 $ link      : chr "identity"
 $ linkfun   :function (mu)  
 $ linkinv   :function (eta)  
 $ variance  :function (mu)  
 $ dev.resids:function (y, mu, wt)  
 $ aic       :function (y, n, mu, wt, dev)  
 $ mu.eta    :function (eta)  
 $ initialize:  expression({  n <- rep.int(1, nobs)  if (is.null(etastart) && is.null(start) && is.null(mustart) && ((family$link| __truncated__
 $ validmu   :function (mu)  
 $ valideta  :function (eta)  
 - attr(*, "class")= chr "family"
> 
> gf <- Gamma()
> gf

Family: Gamma 
Link function: inverse 

> str(gf)
List of 12
 $ family    : chr "Gamma"
 $ link      : chr "inverse"
 $ linkfun   :function (mu)  
 $ linkinv   :function (eta)  
 $ variance  :function (mu)  
 $ dev.resids:function (y, mu, wt)  
 $ aic       :function (y, n, mu, wt, dev)  
 $ mu.eta    :function (eta)  
 $ initialize:  expression({  if (any(y <= 0))  stop("non-positive values not allowed for the 'Gamma' family")  n <- rep.int(1, n| __truncated__
 $ validmu   :function (mu)  
 $ valideta  :function (eta)  
 $ simulate  :function (object, nsim)  
 - attr(*, "class")= chr "family"
> gf$linkinv
function (eta) 
1/eta
<environment: namespace:stats>
> gf$variance(-3:4) #- == (.)^2
[1]  9  4  1  0  1  4  9 16
> 
> ## Binomial with default 'logit' link:  Check some properties visually:
> bi <- binomial()
> et <- seq(-10,10, by=1/8)
> plot(et, bi$mu.eta(et), type="l")
> ## show that mu.eta() is derivative of linkinv() :
> lines((et[-1]+et[-length(et)])/2, col=adjustcolor("red", 1/4),
+       diff(bi$linkinv(et))/diff(et), type="l", lwd=4)
> ## which here is the logistic density:
> lines(et, dlogis(et), lwd=3, col=adjustcolor("blue", 1/4))
> stopifnot(exprs = {
+   all.equal(bi$ mu.eta(et), dlogis(et))
+   all.equal(bi$linkinv(et), plogis(et) -> m)
+   all.equal(bi$linkfun(m ), qlogis(m))    #  logit(.) == qlogis(.) !
+ })
> 
> ## Data from example(glm) :
> d.AD <- data.frame(treatment = gl(3,3),
+                    outcome   = gl(3,1,9),
+                    counts    = c(18,17,15, 20,10,20, 25,13,12))
> glm.D93 <- glm(counts ~ outcome + treatment, d.AD, family = poisson())
> ## Quasipoisson: compare with above / example(glm) :
> glm.qD93 <- glm(counts ~ outcome + treatment, d.AD, family = quasipoisson())
> 
> 
> ## Example of user-specified link, a logit model for p^days
> ## See Shaffer, T.  2004. Auk 121(2): 526-540.
> logexp <- function(days = 1)
+ {
+     linkfun <- function(mu) qlogis(mu^(1/days))
+     linkinv <- function(eta) plogis(eta)^days
+     mu.eta  <- function(eta) days * plogis(eta)^(days-1) *
+                   binomial()$mu.eta(eta)
+     valideta <- function(eta) TRUE
+     link <- paste0("logexp(", days, ")")
+     structure(list(linkfun = linkfun, linkinv = linkinv,
+                    mu.eta = mu.eta, valideta = valideta, name = link),
+               class = "link-glm")
+ }
> (bil3 <- binomial(logexp(3)))

Family: binomial 
Link function: logexp(3) 

> ## Don't show: 
> stopifnot(length(bil3$mu.eta(as.double(0:5))) == 6)
> ## End(Don't show)
> ## in practice this would be used with a vector of 'days', in
> ## which case use an offset of 0 in the corresponding formula
> ## to get the null deviance right.
> 
> ## Binomial with identity link: often not a good idea, as both
> ## computationally and conceptually difficult:
> binomial(link = "identity")  ## is exactly the same as

Family: binomial 
Link function: identity 

> binomial(link = make.link("identity"))

Family: binomial 
Link function: identity 

> 
> 
> 
> ## tests of quasi
> x <- rnorm(100)
> y <- rpois(100, exp(1+x))
> glm(y ~ x, family = quasi(variance = "mu", link = "log"))

Call:  glm(formula = y ~ x, family = quasi(variance = "mu", link = "log"))

Coefficients:
(Intercept)            x  
     0.8596       1.0875  

Degrees of Freedom: 99 Total (i.e. Null);  98 Residual
Null Deviance:	    481.9 
Residual Deviance: 101.7 	AIC: NA
> # which is the same as
> glm(y ~ x, family = poisson)

Call:  glm(formula = y ~ x, family = poisson)

Coefficients:
(Intercept)            x  
     0.8596       1.0875  

Degrees of Freedom: 99 Total (i.e. Null);  98 Residual
Null Deviance:	    481.9 
Residual Deviance: 101.7 	AIC: 364
> glm(y ~ x, family = quasi(variance = "mu^2", link = "log"))

Call:  glm(formula = y ~ x, family = quasi(variance = "mu^2", link = "log"))

Coefficients:
(Intercept)            x  
     0.6902       1.4546  

Degrees of Freedom: 99 Total (i.e. Null);  98 Residual
Null Deviance:	    83.85 
Residual Deviance: 32.45 	AIC: NA
> ## Not run: glm(y ~ x, family = quasi(variance = "mu^3", link = "log")) # fails
> y <- rbinom(100, 1, plogis(x))
> # need to set a starting value for the next fit
> glm(y ~ x, family = quasi(variance = "mu(1-mu)", link = "logit"), start = c(0,1))

Call:  glm(formula = y ~ x, family = quasi(variance = "mu(1-mu)", link = "logit"), 
    start = c(0, 1))

Coefficients:
(Intercept)            x  
   -0.08334      0.38518  

Degrees of Freedom: 99 Total (i.e. Null);  98 Residual
Null Deviance:	    138.6 
Residual Deviance: 135.8 	AIC: NA
> 
> 
> 
> cleanEx()
> nameEx("fft")
> ### * fft
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: fft
> ### Title: Fast Discrete Fourier Transform (FFT)
> ### Aliases: fft mvfft
> ### Keywords: math dplot
> 
> ### ** Examples
> 
> x <- 1:4
> fft(x)
[1] 10+0i -2+2i -2+0i -2-2i
> fft(fft(x), inverse = TRUE)/length(x)
[1] 1+0i 2+0i 3+0i 4+0i
> 
> ## Slow Discrete Fourier Transform (DFT) - e.g., for checking the formula
> fft0 <- function(z, inverse=FALSE) {
+   n <- length(z)
+   if(n == 0) return(z)
+   k <- 0:(n-1)
+   ff <- (if(inverse) 1 else -1) * 2*pi * 1i * k/n
+   vapply(1:n, function(h) sum(z * exp(ff*(h-1))), complex(1))
+ }
> 
> relD <- function(x,y) 2* abs(x - y) / abs(x + y)
> n <- 2^8
> z <- complex(n, rnorm(n), rnorm(n))
> 
> 
> cleanEx()
> nameEx("filter")
> ### * filter
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: filter
> ### Title: Linear Filtering on a Time Series
> ### Aliases: filter
> ### Keywords: ts
> 
> ### ** Examples
> 
> x <- 1:100
> filter(x, rep(1, 3))
Time Series:
Start = 1 
End = 100 
Frequency = 1 
  [1]  NA   6   9  12  15  18  21  24  27  30  33  36  39  42  45  48  51  54
 [19]  57  60  63  66  69  72  75  78  81  84  87  90  93  96  99 102 105 108
 [37] 111 114 117 120 123 126 129 132 135 138 141 144 147 150 153 156 159 162
 [55] 165 168 171 174 177 180 183 186 189 192 195 198 201 204 207 210 213 216
 [73] 219 222 225 228 231 234 237 240 243 246 249 252 255 258 261 264 267 270
 [91] 273 276 279 282 285 288 291 294 297  NA
> filter(x, rep(1, 3), sides = 1)
Time Series:
Start = 1 
End = 100 
Frequency = 1 
  [1]  NA  NA   6   9  12  15  18  21  24  27  30  33  36  39  42  45  48  51
 [19]  54  57  60  63  66  69  72  75  78  81  84  87  90  93  96  99 102 105
 [37] 108 111 114 117 120 123 126 129 132 135 138 141 144 147 150 153 156 159
 [55] 162 165 168 171 174 177 180 183 186 189 192 195 198 201 204 207 210 213
 [73] 216 219 222 225 228 231 234 237 240 243 246 249 252 255 258 261 264 267
 [91] 270 273 276 279 282 285 288 291 294 297
> filter(x, rep(1, 3), sides = 1, circular = TRUE)
Time Series:
Start = 1 
End = 100 
Frequency = 1 
  [1] 200 103   6   9  12  15  18  21  24  27  30  33  36  39  42  45  48  51
 [19]  54  57  60  63  66  69  72  75  78  81  84  87  90  93  96  99 102 105
 [37] 108 111 114 117 120 123 126 129 132 135 138 141 144 147 150 153 156 159
 [55] 162 165 168 171 174 177 180 183 186 189 192 195 198 201 204 207 210 213
 [73] 216 219 222 225 228 231 234 237 240 243 246 249 252 255 258 261 264 267
 [91] 270 273 276 279 282 285 288 291 294 297
> 
> filter(presidents, rep(1, 3))
     Qtr1 Qtr2 Qtr3 Qtr4
1945   NA   NA  244  220
1946  188  156  125  110
1947  127  149  169  145
1948  130   NA   NA   NA
1949   NA  183  165  153
1950  133  128  122  121
1951   99   92   79   80
1952   80   NA   NA   NA
1953  165  208  209  206
1954  192  203  189  199
1955  196  218  220  228
1956  220  214  213  221
1957  216  204  182  180
1958  166  157  149  157
1959  171  180  189  198
1960  199  194  180  190
1961  212  226  232  228
1962  228  212  207  212
1963  214  202  183  199
1964  210  222  211  209
1965  204  204  195  194
1966  171  165  146  144
1967  140  134  136  120
1968  131  120  128  138
1969  168  189  186  187
1970  175  180  166  164
1971  151  153  151  152
1972  159   NA   NA   NA
1973   NA  152  111   95
1974   80   77   73   NA
> 
> 
> 
> cleanEx()
> nameEx("fisher.test")
> ### * fisher.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: fisher.test
> ### Title: Fisher's Exact Test for Count Data
> ### Aliases: fisher.test
> ### Keywords: htest
> 
> ### ** Examples
> 
> ## Agresti (1990, p. 61f; 2002, p. 91) Fisher's Tea Drinker
> ## A British woman claimed to be able to distinguish whether milk or
> ##  tea was added to the cup first.  To test, she was given 8 cups of
> ##  tea, in four of which milk was added first.  The null hypothesis
> ##  is that there is no association between the true order of pouring
> ##  and the woman's guess, the alternative that there is a positive
> ##  association (that the odds ratio is greater than 1).
> TeaTasting <-
+ matrix(c(3, 1, 1, 3),
+        nrow = 2,
+        dimnames = list(Guess = c("Milk", "Tea"),
+                        Truth = c("Milk", "Tea")))
> fisher.test(TeaTasting, alternative = "greater")

	Fisher's Exact Test for Count Data

data:  TeaTasting
p-value = 0.2429
alternative hypothesis: true odds ratio is greater than 1
95 percent confidence interval:
 0.3135693       Inf
sample estimates:
odds ratio 
  6.408309 

> ## => p = 0.2429, association could not be established
> 
> ## Fisher (1962, 1970), Criminal convictions of like-sex twins
> Convictions <- matrix(c(2, 10, 15, 3), nrow = 2,
+ 	              dimnames =
+ 	       list(c("Dizygotic", "Monozygotic"),
+ 		    c("Convicted", "Not convicted")))
> Convictions
            Convicted Not convicted
Dizygotic           2            15
Monozygotic        10             3
> fisher.test(Convictions, alternative = "less")

	Fisher's Exact Test for Count Data

data:  Convictions
p-value = 0.0004652
alternative hypothesis: true odds ratio is less than 1
95 percent confidence interval:
 0.0000000 0.2849601
sample estimates:
odds ratio 
0.04693661 

> fisher.test(Convictions, conf.int = FALSE)

	Fisher's Exact Test for Count Data

data:  Convictions
p-value = 0.0005367
alternative hypothesis: true odds ratio is not equal to 1
sample estimates:
odds ratio 
0.04693661 

> fisher.test(Convictions, conf.level = 0.95)$conf.int
[1] 0.003325764 0.363182271
attr(,"conf.level")
[1] 0.95
> fisher.test(Convictions, conf.level = 0.99)$conf.int
[1] 0.001386333 0.578851645
attr(,"conf.level")
[1] 0.99
> 
> ## A r x c table  Agresti (2002, p. 57) Job Satisfaction
> Job <- matrix(c(1,2,1,0, 3,3,6,1, 10,10,14,9, 6,7,12,11), 4, 4,
+            dimnames = list(income = c("< 15k", "15-25k", "25-40k", "> 40k"),
+                      satisfaction = c("VeryD", "LittleD", "ModerateS", "VeryS")))
> fisher.test(Job) # 0.7827

	Fisher's Exact Test for Count Data

data:  Job
p-value = 0.7827
alternative hypothesis: two.sided

> fisher.test(Job, simulate.p.value = TRUE, B = 1e5) # also close to 0.78

	Fisher's Exact Test for Count Data with simulated p-value (based on
	1e+05 replicates)

data:  Job
p-value = 0.7842
alternative hypothesis: two.sided

> 
> ## 6th example in Mehta & Patel's JASA paper
> MP6 <- rbind(
+         c(1,2,2,1,1,0,1),
+         c(2,0,0,2,3,0,0),
+         c(0,1,1,1,2,7,3),
+         c(1,1,2,0,0,0,1),
+         c(0,1,1,1,1,0,0))
> fisher.test(MP6)

	Fisher's Exact Test for Count Data

data:  MP6
p-value = 0.03929
alternative hypothesis: two.sided

> # Exactly the same p-value, as Cochran's conditions are never met:
> fisher.test(MP6, hybrid=TRUE)

	Fisher's Exact Test for Count Data hybrid using asym.chisq. iff (exp=5,
	perc=80, Emin=1)

data:  MP6
p-value = 0.03929
alternative hypothesis: two.sided

> 
> 
> 
> cleanEx()
> nameEx("fivenum")
> ### * fivenum
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: fivenum
> ### Title: Tukey Five-Number Summaries
> ### Aliases: fivenum
> ### Keywords: univar robust distribution
> 
> ### ** Examples
> 
> fivenum(c(rnorm(100), -1:1/0))
[1]       -Inf -0.5425200  0.1139092  0.6969634        Inf
> 
> 
> 
> cleanEx()
> nameEx("fligner.test")
> ### * fligner.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: fligner.test
> ### Title: Fligner-Killeen Test of Homogeneity of Variances
> ### Aliases: fligner.test fligner.test.default fligner.test.formula
> ### Keywords: htest
> 
> ### ** Examples
> 
> require(graphics)
> 
> plot(count ~ spray, data = InsectSprays)
> fligner.test(InsectSprays$count, InsectSprays$spray)

	Fligner-Killeen test of homogeneity of variances

data:  InsectSprays$count and InsectSprays$spray
Fligner-Killeen:med chi-squared = 14.483, df = 5, p-value = 0.01282

> fligner.test(count ~ spray, data = InsectSprays)

	Fligner-Killeen test of homogeneity of variances

data:  count by spray
Fligner-Killeen:med chi-squared = 14.483, df = 5, p-value = 0.01282

> ## Compare this to bartlett.test()
> 
> 
> 
> cleanEx()
> nameEx("formula")
> ### * formula
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: formula
> ### Title: Model Formulae
> ### Aliases: formula formula.default formula.formula formula.terms
> ###   formula.data.frame DF2formula as.formula print.formula [.formula
> ### Keywords: models
> 
> ### ** Examples
> 
> class(fo <- y ~ x1*x2) # "formula"
[1] "formula"
> fo
y ~ x1 * x2
> typeof(fo)  # R internal : "language"
[1] "language"
> terms(fo)
y ~ x1 * x2
attr(,"variables")
list(y, x1, x2)
attr(,"factors")
   x1 x2 x1:x2
y   0  0     0
x1  1  0     1
x2  0  1     1
attr(,"term.labels")
[1] "x1"    "x2"    "x1:x2"
attr(,"order")
[1] 1 1 2
attr(,"intercept")
[1] 1
attr(,"response")
[1] 1
attr(,".Environment")
<environment: R_GlobalEnv>
> 
> environment(fo)
<environment: R_GlobalEnv>
> environment(as.formula("y ~ x"))
<environment: R_GlobalEnv>
> environment(as.formula("y ~ x", env = new.env()))
<environment: 0x65be7c0>
> 
> 
> ## Create a formula for a model with a large number of variables:
> xnam <- paste0("x", 1:25)
> (fmla <- as.formula(paste("y ~ ", paste(xnam, collapse= "+"))))
y ~ x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + 
    x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 + x21 + 
    x22 + x23 + x24 + x25
> ## Equivalent with reformulate():
> fmla2 <- reformulate(xnam, response = "y")
> stopifnot(identical(fmla, fmla2))
> 
> 
> 
> cleanEx()
> nameEx("formula.nls")
> ### * formula.nls
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: formula.nls
> ### Title: Extract Model Formula from nls Object
> ### Aliases: formula.nls
> ### Keywords: models
> 
> ### ** Examples
> 
> fm1 <- nls(circumference ~ A/(1+exp((B-age)/C)), Orange,
+            start = list(A = 160, B = 700, C = 350))
> formula(fm1)
circumference ~ A/(1 + exp((B - age)/C))
> 
> 
> 
> cleanEx()
> nameEx("friedman.test")
> ### * friedman.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: friedman.test
> ### Title: Friedman Rank Sum Test
> ### Aliases: friedman.test friedman.test.default friedman.test.formula
> ### Keywords: htest
> 
> ### ** Examples
> 
> ## Hollander & Wolfe (1973), p. 140ff.
> ## Comparison of three methods ("round out", "narrow angle", and
> ##  "wide angle") for rounding first base.  For each of 18 players
> ##  and the three method, the average time of two runs from a point on
> ##  the first base line 35ft from home plate to a point 15ft short of
> ##  second base is recorded.
> RoundingTimes <-
+ matrix(c(5.40, 5.50, 5.55,
+          5.85, 5.70, 5.75,
+          5.20, 5.60, 5.50,
+          5.55, 5.50, 5.40,
+          5.90, 5.85, 5.70,
+          5.45, 5.55, 5.60,
+          5.40, 5.40, 5.35,
+          5.45, 5.50, 5.35,
+          5.25, 5.15, 5.00,
+          5.85, 5.80, 5.70,
+          5.25, 5.20, 5.10,
+          5.65, 5.55, 5.45,
+          5.60, 5.35, 5.45,
+          5.05, 5.00, 4.95,
+          5.50, 5.50, 5.40,
+          5.45, 5.55, 5.50,
+          5.55, 5.55, 5.35,
+          5.45, 5.50, 5.55,
+          5.50, 5.45, 5.25,
+          5.65, 5.60, 5.40,
+          5.70, 5.65, 5.55,
+          6.30, 6.30, 6.25),
+        nrow = 22,
+        byrow = TRUE,
+        dimnames = list(1 : 22,
+                        c("Round Out", "Narrow Angle", "Wide Angle")))
> friedman.test(RoundingTimes)

	Friedman rank sum test

data:  RoundingTimes
Friedman chi-squared = 11.143, df = 2, p-value = 0.003805

> ## => strong evidence against the null that the methods are equivalent
> ##    with respect to speed
> 
> wb <- aggregate(warpbreaks$breaks,
+                 by = list(w = warpbreaks$wool,
+                           t = warpbreaks$tension),
+                 FUN = mean)
> wb
  w t        x
1 A L 44.55556
2 B L 28.22222
3 A M 24.00000
4 B M 28.77778
5 A H 24.55556
6 B H 18.77778
> friedman.test(wb$x, wb$w, wb$t)

	Friedman rank sum test

data:  wb$x, wb$w and wb$t
Friedman chi-squared = 0.33333, df = 1, p-value = 0.5637

> friedman.test(x ~ w | t, data = wb)

	Friedman rank sum test

data:  x and w and t
Friedman chi-squared = 0.33333, df = 1, p-value = 0.5637

> 
> 
> 
> cleanEx()
> nameEx("ftable")
> ### * ftable
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ftable
> ### Title: Flat Contingency Tables
> ### Aliases: ftable ftable.default
> ### Keywords: category
> 
> ### ** Examples
> 
> ## Start with a contingency table.
> ftable(Titanic, row.vars = 1:3)
                   Survived  No Yes
Class Sex    Age                   
1st   Male   Child            0   5
             Adult          118  57
      Female Child            0   1
             Adult            4 140
2nd   Male   Child            0  11
             Adult          154  14
      Female Child            0  13
             Adult           13  80
3rd   Male   Child           35  13
             Adult          387  75
      Female Child           17  14
             Adult           89  76
Crew  Male   Child            0   0
             Adult          670 192
      Female Child            0   0
             Adult            3  20
> ftable(Titanic, row.vars = 1:2, col.vars = "Survived")
             Survived  No Yes
Class Sex                    
1st   Male            118  62
      Female            4 141
2nd   Male            154  25
      Female           13  93
3rd   Male            422  88
      Female          106  90
Crew  Male            670 192
      Female            3  20
> ftable(Titanic, row.vars = 2:1, col.vars = "Survived")
             Survived  No Yes
Sex    Class                 
Male   1st            118  62
       2nd            154  25
       3rd            422  88
       Crew           670 192
Female 1st              4 141
       2nd             13  93
       3rd            106  90
       Crew             3  20
> ## Don't show: 
> . <- integer()
> (f04 <- ftable(Titanic, col.vars= .))
Class Sex    Age   Survived     
1st   Male   Child No          0
                   Yes         5
             Adult No        118
                   Yes        57
      Female Child No          0
                   Yes         1
             Adult No          4
                   Yes       140
2nd   Male   Child No          0
                   Yes        11
             Adult No        154
                   Yes        14
      Female Child No          0
                   Yes        13
             Adult No         13
                   Yes        80
3rd   Male   Child No         35
                   Yes        13
             Adult No        387
                   Yes        75
      Female Child No         17
                   Yes        14
             Adult No         89
                   Yes        76
Crew  Male   Child No          0
                   Yes         0
             Adult No        670
                   Yes       192
      Female Child No          0
                   Yes         0
             Adult No          3
                   Yes        20
> (f10 <- ftable(Titanic, col.vars= 1, row.vars= .))
Class 1st 2nd 3rd Crew
                      
      325 285 706  885
> (f01 <- ftable(Titanic, col.vars= ., row.vars= 1))
Class     
1st    325
2nd    285
3rd    706
Crew   885
> (f00 <- ftable(Titanic, col.vars= ., row.vars= .))
     
 2201
> stopifnot(
+   dim(f04) == c(32,1),
+   dim(f10) == c(1,4),
+   dim(f01) == c(4,1),
+   dim(f00) == c(1,1))
> ## End(Don't show)
> ## Start with a data frame.
> x <- ftable(mtcars[c("cyl", "vs", "am", "gear")])
> x
          gear  3  4  5
cyl vs am              
4   0  0        0  0  0
       1        0  0  1
    1  0        1  2  0
       1        0  6  1
6   0  0        0  0  0
       1        0  2  1
    1  0        2  2  0
       1        0  0  0
8   0  0       12  0  0
       1        0  0  2
    1  0        0  0  0
       1        0  0  0
> ftable(x, row.vars = c(2, 4))
        cyl  4     6     8   
        am   0  1  0  1  0  1
vs gear                      
0  3         0  0  0  0 12  0
   4         0  0  0  2  0  0
   5         0  1  0  1  0  2
1  3         1  0  2  0  0  0
   4         2  6  2  0  0  0
   5         0  1  0  0  0  0
> 
> ## Start with expressions, use table()'s "dnn" to change labels
> ftable(mtcars$cyl, mtcars$vs, mtcars$am, mtcars$gear, row.vars = c(2, 4),
+        dnn = c("Cylinders", "V/S", "Transmission", "Gears"))
          Cylinders     4     6     8   
          Transmission  0  1  0  1  0  1
V/S Gears                               
0   3                   0  0  0  0 12  0
    4                   0  0  0  2  0  0
    5                   0  1  0  1  0  2
1   3                   1  0  2  0  0  0
    4                   2  6  2  0  0  0
    5                   0  1  0  0  0  0
> 
> 
> 
> cleanEx()
> nameEx("ftable.formula")
> ### * ftable.formula
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ftable.formula
> ### Title: Formula Notation for Flat Contingency Tables
> ### Aliases: ftable.formula
> ### Keywords: category
> 
> ### ** Examples
> 
> Titanic
, , Age = Child, Survived = No

      Sex
Class  Male Female
  1st     0      0
  2nd     0      0
  3rd    35     17
  Crew    0      0

, , Age = Adult, Survived = No

      Sex
Class  Male Female
  1st   118      4
  2nd   154     13
  3rd   387     89
  Crew  670      3

, , Age = Child, Survived = Yes

      Sex
Class  Male Female
  1st     5      1
  2nd    11     13
  3rd    13     14
  Crew    0      0

, , Age = Adult, Survived = Yes

      Sex
Class  Male Female
  1st    57    140
  2nd    14     80
  3rd    75     76
  Crew  192     20

> x <- ftable(Survived ~ ., data = Titanic)
> x
                   Survived  No Yes
Class Sex    Age                   
1st   Male   Child            0   5
             Adult          118  57
      Female Child            0   1
             Adult            4 140
2nd   Male   Child            0  11
             Adult          154  14
      Female Child            0  13
             Adult           13  80
3rd   Male   Child           35  13
             Adult          387  75
      Female Child           17  14
             Adult           89  76
Crew  Male   Child            0   0
             Adult          670 192
      Female Child            0   0
             Adult            3  20
> ftable(Sex ~ Class + Age, data = x)
            Sex Male Female
Class Age                  
1st   Child        5      1
      Adult      175    144
2nd   Child       11     13
      Adult      168     93
3rd   Child       48     31
      Adult      462    165
Crew  Child        0      0
      Adult      862     23
> 
> 
> 
> cleanEx()
> nameEx("getInitial")
> ### * getInitial
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: getInitial
> ### Title: Get Initial Parameter Estimates
> ### Aliases: getInitial getInitial.default getInitial.formula
> ###   getInitial.selfStart
> ### Keywords: models nonlinear manip
> 
> ### ** Examples
> 
> PurTrt <- Puromycin[ Puromycin$state == "treated", ]
> print(getInitial( rate ~ SSmicmen( conc, Vm, K ), PurTrt ), digits = 3)
      Vm        K 
212.6837   0.0641 
> 
> 
> 
> cleanEx()
> nameEx("glm")
> ### * glm
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: glm
> ### Title: Fitting Generalized Linear Models
> ### Aliases: glm glm.fit weights.glm
> ### Keywords: models regression
> 
> ### ** Examples
> 
> ## Dobson (1990) Page 93: Randomized Controlled Trial :
> counts <- c(18,17,15,20,10,20,25,13,12)
> outcome <- gl(3,1,9)
> treatment <- gl(3,3)
> data.frame(treatment, outcome, counts) # showing data
  treatment outcome counts
1         1       1     18
2         1       2     17
3         1       3     15
4         2       1     20
5         2       2     10
6         2       3     20
7         3       1     25
8         3       2     13
9         3       3     12
> glm.D93 <- glm(counts ~ outcome + treatment, family = poisson())
> anova(glm.D93)
Analysis of Deviance Table

Model: poisson, link: log

Response: counts

Terms added sequentially (first to last)


          Df Deviance Resid. Df Resid. Dev
NULL                          8    10.5814
outcome    2   5.4523         6     5.1291
treatment  2   0.0000         4     5.1291
> ## Computing AIC [in many ways]:
> (A0 <- AIC(glm.D93))
[1] 56.76132
> (ll <- logLik(glm.D93))
'log Lik.' -23.38066 (df=5)
> A1 <- -2*c(ll) + 2*attr(ll, "df")
> A2 <- glm.D93$family$aic(counts, mu=fitted(glm.D93), wt=1) +
+         2 * length(coef(glm.D93))
> stopifnot(exprs = {
+   all.equal(A0, A1)
+   all.equal(A1, A2)
+   all.equal(A1, glm.D93$aic)
+ })
> 
> 
> 
> # A Gamma example, from McCullagh & Nelder (1989, pp. 300-2)
> clotting <- data.frame(
+     u = c(5,10,15,20,30,40,60,80,100),
+     lot1 = c(118,58,42,35,27,25,21,19,18),
+     lot2 = c(69,35,26,21,18,16,13,12,12))
> summary(glm(lot1 ~ log(u), data = clotting, family = Gamma))

Call:
glm(formula = lot1 ~ log(u), family = Gamma, data = clotting)

Deviance Residuals: 
     Min        1Q    Median        3Q       Max  
-0.04008  -0.03756  -0.02637   0.02905   0.08641  

Coefficients:
              Estimate Std. Error t value Pr(>|t|)    
(Intercept) -0.0165544  0.0009275  -17.85 4.28e-07 ***
log(u)       0.0153431  0.0004150   36.98 2.75e-09 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

(Dispersion parameter for Gamma family taken to be 0.002446059)

    Null deviance: 3.51283  on 8  degrees of freedom
Residual deviance: 0.01673  on 7  degrees of freedom
AIC: 37.99

Number of Fisher Scoring iterations: 3

> summary(glm(lot2 ~ log(u), data = clotting, family = Gamma))

Call:
glm(formula = lot2 ~ log(u), family = Gamma, data = clotting)

Deviance Residuals: 
     Min        1Q    Median        3Q       Max  
-0.05574  -0.02925   0.01030   0.01714   0.06371  

Coefficients:
              Estimate Std. Error t value Pr(>|t|)    
(Intercept) -0.0239085  0.0013265  -18.02 4.00e-07 ***
log(u)       0.0235992  0.0005768   40.91 1.36e-09 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

(Dispersion parameter for Gamma family taken to be 0.001813354)

    Null deviance: 3.118557  on 8  degrees of freedom
Residual deviance: 0.012672  on 7  degrees of freedom
AIC: 27.032

Number of Fisher Scoring iterations: 3

> ## Aliased ("S"ingular) -> 1 NA coefficient
> (fS <- glm(lot2 ~ log(u) + log(u^2), data = clotting, family = Gamma))

Call:  glm(formula = lot2 ~ log(u) + log(u^2), family = Gamma, data = clotting)

Coefficients:
(Intercept)       log(u)     log(u^2)  
   -0.02391      0.02360           NA  

Degrees of Freedom: 8 Total (i.e. Null);  7 Residual
Null Deviance:	    3.119 
Residual Deviance: 0.01267 	AIC: 27.03
> tools::assertError(update(fS, singular.ok=FALSE), verbose=interactive())
> ## -> .. "singular fit encountered"
> 
> ## Not run: 
> ##D ## for an example of the use of a terms object as a formula
> ##D demo(glm.vr)
> ## End(Not run)
> 
> 
> cleanEx()
> nameEx("glm.control")
> ### * glm.control
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: glm.control
> ### Title: Auxiliary for Controlling GLM Fitting
> ### Aliases: glm.control
> ### Keywords: optimize models
> 
> ### ** Examples
> 
> 
> cleanEx()
> nameEx("hclust")
> ### * hclust
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: hclust
> ### Title: Hierarchical Clustering
> ### Aliases: hclust plot.hclust print.hclust
> ### Keywords: multivariate cluster
> 
> ### ** Examples
> 
> require(graphics)
> 
> ### Example 1: Violent crime rates by US state
> 
> hc <- hclust(dist(USArrests), "ave")
> plot(hc)
> plot(hc, hang = -1)
> 
> ## Do the same with centroid clustering and *squared* Euclidean distance,
> ## cut the tree into ten clusters and reconstruct the upper part of the
> ## tree from the cluster centers.
> hc <- hclust(dist(USArrests)^2, "cen")
> memb <- cutree(hc, k = 10)
> cent <- NULL
> for(k in 1:10){
+   cent <- rbind(cent, colMeans(USArrests[memb == k, , drop = FALSE]))
+ }
> hc1 <- hclust(dist(cent)^2, method = "cen", members = table(memb))
> opar <- par(mfrow = c(1, 2))
> plot(hc,  labels = FALSE, hang = -1, main = "Original Tree")
> plot(hc1, labels = FALSE, hang = -1, main = "Re-start from 10 clusters")
> par(opar)
> 
> ### Example 2: Straight-line distances among 10 US cities
> ##  Compare the results of algorithms "ward.D" and "ward.D2"
> 
> mds2 <- -cmdscale(UScitiesD)
> plot(mds2, type="n", axes=FALSE, ann=FALSE)
> text(mds2, labels=rownames(mds2), xpd = NA)
> 
> hcity.D  <- hclust(UScitiesD, "ward.D") # "wrong"
> hcity.D2 <- hclust(UScitiesD, "ward.D2")
> opar <- par(mfrow = c(1, 2))
> plot(hcity.D,  hang=-1)
> plot(hcity.D2, hang=-1)
> par(opar)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("heatmap")
> ### * heatmap
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: heatmap
> ### Title: Draw a Heat Map
> ### Aliases: heatmap
> ### Keywords: hplot
> 
> ### ** Examples
> 
> require(graphics); require(grDevices)
> x  <- as.matrix(mtcars)
> rc <- rainbow(nrow(x), start = 0, end = .3)
> cc <- rainbow(ncol(x), start = 0, end = .3)
> hv <- heatmap(x, col = cm.colors(256), scale = "column",
+               RowSideColors = rc, ColSideColors = cc, margins = c(5,10),
+               xlab = "specification variables", ylab =  "Car Models",
+               main = "heatmap(<Mtcars data>, ..., scale = \"column\")")
> utils::str(hv) # the two re-ordering index vectors
List of 4
 $ rowInd: int [1:32] 31 17 16 15 5 25 29 24 7 6 ...
 $ colInd: int [1:11] 2 9 8 11 6 5 10 7 1 4 ...
 $ Rowv  : NULL
 $ Colv  : NULL
> 
> ## no column dendrogram (nor reordering) at all:
> heatmap(x, Colv = NA, col = cm.colors(256), scale = "column",
+         RowSideColors = rc, margins = c(5,10),
+         xlab = "specification variables", ylab =  "Car Models",
+         main = "heatmap(<Mtcars data>, ..., scale = \"column\")")
> ## Don't show: 
> ## no row dendrogram (nor reordering) at all:
> heatmap(x, Rowv = NA, col = cm.colors(256), scale = "column",
+         ColSideColors = cc, margins = c(5,10),
+         xlab = "xlab", ylab =  "ylab")  # no main
> ## End(Don't show)
> ## "no nothing"
> heatmap(x, Rowv = NA, Colv = NA, scale = "column",
+         main = "heatmap(*, NA, NA) ~= image(t(x))")
> 
> round(Ca <- cor(attitude), 2)
           rating complaints privileges learning raises critical advance
rating       1.00       0.83       0.43     0.62   0.59     0.16    0.16
complaints   0.83       1.00       0.56     0.60   0.67     0.19    0.22
privileges   0.43       0.56       1.00     0.49   0.45     0.15    0.34
learning     0.62       0.60       0.49     1.00   0.64     0.12    0.53
raises       0.59       0.67       0.45     0.64   1.00     0.38    0.57
critical     0.16       0.19       0.15     0.12   0.38     1.00    0.28
advance      0.16       0.22       0.34     0.53   0.57     0.28    1.00
> symnum(Ca) # simple graphic
           rt cm p l rs cr a
rating     1                
complaints +  1             
privileges .  .  1          
learning   ,  .  . 1        
raises     .  ,  . , 1      
critical             .  1   
advance          . . .     1
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> heatmap(Ca,               symm = TRUE, margins = c(6,6)) # with reorder()
> heatmap(Ca, Rowv = FALSE, symm = TRUE, margins = c(6,6)) # _NO_ reorder()
> ## slightly artificial with color bar, without and with ordering:
> cc <- rainbow(nrow(Ca))
> heatmap(Ca, Rowv = FALSE, symm = TRUE, RowSideColors = cc, ColSideColors = cc,
+ 	margins = c(6,6))
> heatmap(Ca,		symm = TRUE, RowSideColors = cc, ColSideColors = cc,
+ 	margins = c(6,6))
> 
> ## For variable clustering, rather use distance based on cor():
> symnum( cU <- cor(USJudgeRatings) )
     CO I DM DI CF DE PR F O W PH R
CONT 1                             
INTG    1                          
DMNR    B 1                        
DILG    + +  1                     
CFMG    + +  B  1                  
DECI    + +  B  B  1               
PREP    + +  B  B  B  1            
FAMI    + +  B  *  *  B  1         
ORAL    * *  B  B  *  B  B 1       
WRIT    * +  B  *  *  B  B B 1     
PHYS    , ,  +  +  +  +  + + + 1   
RTEN    * *  *  *  *  B  * B B *  1
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> 
> hU <- heatmap(cU, Rowv = FALSE, symm = TRUE, col = topo.colors(16),
+              distfun = function(c) as.dist(1 - c), keep.dendro = TRUE)
> ## The Correlation matrix with same reordering:
> round(100 * cU[hU[[1]], hU[[2]]])
     CONT INTG DMNR PHYS DILG CFMG DECI RTEN ORAL WRIT PREP FAMI
CONT  100  -13  -15    5    1   14    9   -3   -1   -4    1   -3
INTG  -13  100   96   74   87   81   80   94   91   91   88   87
DMNR  -15   96  100   79   84   81   80   94   91   89   86   84
PHYS    5   74   79  100   81   88   87   91   89   86   85   84
DILG    1   87   84   81  100   96   96   93   95   96   98   96
CFMG   14   81   81   88   96  100   98   93   95   94   96   94
DECI    9   80   80   87   96   98  100   92   95   95   96   94
RTEN   -3   94   94   91   93   93   92  100   98   97   95   94
ORAL   -1   91   91   89   95   95   95   98  100   99   98   98
WRIT   -4   91   89   86   96   94   95   97   99  100   99   99
PREP    1   88   86   85   98   96   96   95   98   99  100   99
FAMI   -3   87   84   84   96   94   94   94   98   99   99  100
> ## The column dendrogram:
> utils::str(hU$Colv)
--[dendrogram w/ 2 branches and 12 members at h = 1.15]
  |--leaf "CONT" 
  `--[dendrogram w/ 2 branches and 11 members at h = 0.258]
     |--[dendrogram w/ 2 branches and 2 members at h = 0.0354]
     |  |--leaf "INTG" 
     |  `--leaf "DMNR" 
     `--[dendrogram w/ 2 branches and 9 members at h = 0.187]
        |--leaf "PHYS" 
        `--[dendrogram w/ 2 branches and 8 members at h = 0.075]
           |--[dendrogram w/ 2 branches and 3 members at h = 0.0438]
           |  |--leaf "DILG" 
           |  `--[dendrogram w/ 2 branches and 2 members at h = 0.0189]
           |     |--leaf "CFMG" 
           |     `--leaf "DECI" 
           `--[dendrogram w/ 2 branches and 5 members at h = 0.0584]
              |--leaf "RTEN" 
              `--[dendrogram w/ 2 branches and 4 members at h = 0.0187]
                 |--[dendrogram w/ 2 branches and 2 members at h = 0.00657]
                 |  |--leaf "ORAL" 
                 |  `--leaf "WRIT" 
                 `--[dendrogram w/ 2 branches and 2 members at h = 0.0101]
                    |--leaf "PREP" 
                    `--leaf "FAMI" 
> 
> 
> 
> cleanEx()
> nameEx("identify.hclust")
> ### * identify.hclust
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: identify.hclust
> ### Title: Identify Clusters in a Dendrogram
> ### Aliases: identify.hclust
> ### Keywords: cluster iplot
> 
> ### ** Examples
> ## Not run: 
> ##D require(graphics)
> ##D 
> ##D hca <- hclust(dist(USArrests))
> ##D plot(hca)
> ##D (x <- identify(hca)) ##  Terminate with 2nd mouse button !!
> ##D 
> ##D hci <- hclust(dist(iris[,1:4]))
> ##D plot(hci)
> ##D identify(hci, function(k) print(table(iris[k,5])))
> ##D 
> ##D # open a new device (one for dendrogram, one for bars):
> ##D dev.new() # << make that narrow (& small)
> ##D           # and *beside* 1st one
> ##D nD <- dev.cur()            # to be for the barplot
> ##D dev.set(dev.prev())  # old one for dendrogram
> ##D plot(hci)
> ##D ## select subtrees in dendrogram and "see" the species distribution:
> ##D identify(hci, function(k) barplot(table(iris[k,5]), col = 2:4), DEV.FUN = nD)
> ## End(Not run)
> 
> 
> cleanEx()
> nameEx("influence.measures")
> ### * influence.measures
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: influence.measures
> ### Title: Regression Deletion Diagnostics
> ### Aliases: influence.measures hat hatvalues hatvalues.lm rstandard
> ###   rstandard.lm rstandard.glm rstudent rstudent.lm rstudent.glm dfbeta
> ###   dfbeta.lm dfbetas dfbetas.lm dffits covratio cooks.distance
> ###   cooks.distance.lm cooks.distance.glm
> ### Keywords: regression
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## Analysis of the life-cycle savings data
> ## given in Belsley, Kuh and Welsch.
> lm.SR <- lm(sr ~ pop15 + pop75 + dpi + ddpi, data = LifeCycleSavings)
> 
> inflm.SR <- influence.measures(lm.SR)
> which(apply(inflm.SR$is.inf, 1, any))
        Chile United States        Zambia         Libya 
            7            44            46            49 
> # which observations 'are' influential
> summary(inflm.SR) # only these
Potentially influential observations of
	 lm(formula = sr ~ pop15 + pop75 + dpi + ddpi, data = LifeCycleSavings) :

              dfb.1_ dfb.pp15 dfb.pp75 dfb.dpi dfb.ddpi dffit   cov.r   cook.d
Chile         -0.20   0.13     0.22    -0.02    0.12    -0.46    0.65_*  0.04 
United States  0.07  -0.07     0.04    -0.23   -0.03    -0.25    1.66_*  0.01 
Zambia         0.16  -0.08    -0.34     0.09    0.23     0.75    0.51_*  0.10 
Libya          0.55  -0.48    -0.38    -0.02   -1.02_*  -1.16_*  2.09_*  0.27 
              hat    
Chile          0.04  
United States  0.33_*
Zambia         0.06  
Libya          0.53_*
> plot(rstudent(lm.SR) ~ hatvalues(lm.SR)) # recommended by some
> plot(lm.SR, which = 5) # an enhanced version of that via plot(<lm>)
> 
> ## The 'infl' argument is not needed, but avoids recomputation:
> rs <- rstandard(lm.SR)
> iflSR <- influence(lm.SR)
> all.equal(rs, rstandard(lm.SR, infl = iflSR), tolerance = 1e-10)
[1] TRUE
> ## to "see" the larger values:
> 1000 * round(dfbetas(lm.SR, infl = iflSR), 3)
               (Intercept) pop15 pop75  dpi  ddpi
Australia               12   -10   -27   45     0
Austria                -10     6    41  -37    -8
Belgium                -64    51   121  -35    -7
Bolivia                  6   -13   -23   32    41
Brazil                  90   -62  -179  120    68
Canada                   5    -7    10  -35    -3
Chile                 -199   133   220  -20   120
China                   21    -6   -83   52   111
Colombia                39   -52   -25    2     9
Costa Rica            -234   284   142   56   -33
Denmark                -41    21    47  152    49
Ecuador                 72   -95   -61   20    48
Finland               -113   111   117  -44   -17
France                -166   147   219  -29    24
Germany                 -8     8     8   -7     0
Greece                -148   164    29  157   -60
Guatamala               16   -55     6    6    97
Honduras                -2    10   -10    8    -2
Iceland                248  -274  -233 -126   185
India                   21   -16   -14  -14   -19
Ireland               -310   296   482 -257   -93
Italy                   66   -71     3  -70   -29
Japan                  640  -656  -674  146   389
Korea                 -169   135   219    5  -169
Luxembourg             -68    69    44  -28    49
Malta                   37   -49     8  -87   153
Norway                   2     0    -6  -16    -1
Netherlands             14   -17   -12    4    23
New Zealand            -60    65    94  -26   -65
Nicaragua              -12    18    10   -5   -10
Panama                  28   -53    14  -35    -8
Paraguay              -232   164   158  144   270
Peru                   -72   147    91  -86  -287
Philippines           -157   227   157 -111  -171
Portugal               -21    26    -4   40   -28
South Africa            22   -20    -7  -20   -16
South Rhodesia         144  -135   -92  -70   -58
Spain                  -30    31     4   35     5
Sweden                 101   -82   -62 -255   -13
Switzerland             43   -46   -44   91   -19
Turkey                 -11   -12    26    2    25
Tunisia                 74  -105   -77   44   103
United Kingdom          47   -36  -171  126   100
United States           69   -73    37 -233   -33
Venezuela              -51   101   -34  114  -124
Zambia                 164   -79  -339   94   228
Jamaica                110  -100   -57   -7  -295
Uruguay               -134   129    30  131   100
Libya                  551  -483  -380  -19 -1024
Malaysia                37   -61    32  -50   -72
> cat("PRESS :"); (PRESS <- sum( rstandard(lm.SR, type = "predictive")^2 ))
PRESS :[1] 798.939
> stopifnot(all.equal(PRESS, sum( (residuals(lm.SR) / (1 - iflSR$hat))^2)))
> 
> ## Show that "PRE-residuals"  ==  L.O.O. Crossvalidation (CV) errors:
> X <- model.matrix(lm.SR)
> y <- model.response(model.frame(lm.SR))
> ## Leave-one-out CV least-squares prediction errors (relatively fast)
> rCV <- vapply(seq_len(nrow(X)), function(i)
+               y[i] - X[i,] %*% .lm.fit(X[-i,], y[-i])$coefficients,
+               numeric(1))
> ## are the same as the *faster* rstandard(*, "pred") :
> stopifnot(all.equal(rCV, unname(rstandard(lm.SR, type = "predictive"))))
> 
> 
> ## Huber's data [Atkinson 1985]
> xh <- c(-4:0, 10)
> yh <- c(2.48, .73, -.04, -1.44, -1.32, 0)
> lmH <- lm(yh ~ xh)
> im <- influence.measures(lmH)
> is.inf <- apply(im$is.inf, 1, any)
> plot(xh,yh, main = "Huber's data: L.S. line and influential obs.")
> abline(lmH); points(xh[is.inf], yh[is.inf], pch = 20, col = 2)
> 
> ## Irwin's data [Williams 1987]
> xi <- 1:5
> yi <- c(0,2,14,19,30)    # number of mice responding to dose xi
> mi <- rep(40, 5)         # number of mice exposed
> glmI <- glm(cbind(yi, mi -yi) ~ xi, family = binomial)
> signif(cooks.distance(glmI), 3)   # ~= Ci in Table 3, p.184
     1      2      3      4      5 
0.2520 0.2610 1.2900 0.0845 0.3640 
> imI <- influence.measures(glmI)
> stopifnot(all.equal(imI$infmat[,"cook.d"],
+           cooks.distance(glmI)))
> 
> 
> 
> cleanEx()
> nameEx("integrate")
> ### * integrate
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: integrate
> ### Title: Integration of One-Dimensional Functions
> ### Aliases: integrate print.integrate
> ### Keywords: math utilities
> 
> ### ** Examples
> 
> integrate(dnorm, -1.96, 1.96)
0.9500042 with absolute error < 1e-11
> integrate(dnorm, -Inf, Inf)
1 with absolute error < 9.4e-05
> 
> ## a slowly-convergent integral
> integrand <- function(x) {1/((x+1)*sqrt(x))}
> integrate(integrand, lower = 0, upper = Inf)
3.141593 with absolute error < 2.7e-05
> 
> ## don't do this if you really want the integral from 0 to Inf
> integrate(integrand, lower = 0, upper = 10)
2.529038 with absolute error < 3e-04
> integrate(integrand, lower = 0, upper = 100000)
3.135268 with absolute error < 4.2e-07
> integrate(integrand, lower = 0, upper = 1000000, stop.on.error = FALSE)
failed with message ‘the integral is probably divergent’
> 
> ## some functions do not handle vector input properly
> f <- function(x) 2.0
> try(integrate(f, 0, 1))
Error in integrate(f, 0, 1) : 
  evaluation of function gave a result of wrong length
> integrate(Vectorize(f), 0, 1)  ## correct
2 with absolute error < 2.2e-14
> integrate(function(x) rep(2.0, length(x)), 0, 1)  ## correct
2 with absolute error < 2.2e-14
> 
> ## integrate can fail if misused
> integrate(dnorm, 0, 2)
0.4772499 with absolute error < 5.3e-15
> integrate(dnorm, 0, 20)
0.5 with absolute error < 3.7e-05
> integrate(dnorm, 0, 200)
0.5 with absolute error < 1.6e-07
> integrate(dnorm, 0, 2000)
0.5 with absolute error < 4.4e-06
> integrate(dnorm, 0, 20000) ## fails on many systems
0 with absolute error < 0
> integrate(dnorm, 0, Inf)   ## works
0.5 with absolute error < 4.7e-05
> ## Don't show: 
> tools::assertError(
+ ## End(Don't show)
+ integrate(dnorm, 0:1, 20) #-> error!
+ ## "silently" gave  integrate(dnorm, 0, 20)  in earlier versions of R
+ ## Don't show: 
+  , verbose=TRUE)
Asserted error: length(lower) == 1 is not TRUE
> ## End(Don't show)
> 
> 
> 
> cleanEx()
> nameEx("interaction.plot")
> ### * interaction.plot
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: interaction.plot
> ### Title: Two-way Interaction Plot
> ### Aliases: interaction.plot
> ### Keywords: hplot
> 
> ### ** Examples
> 
> require(graphics)
> 
> with(ToothGrowth, {
+ interaction.plot(dose, supp, len, fixed = TRUE)
+ dose <- ordered(dose)
+ interaction.plot(dose, supp, len, fixed = TRUE,
+                  col = 2:3, leg.bty = "o", xtick = TRUE)
+ interaction.plot(dose, supp, len, fixed = TRUE, col = 2:3, type = "p")
+ })
> 
> with(OrchardSprays, {
+   interaction.plot(treatment, rowpos, decrease)
+   interaction.plot(rowpos, treatment, decrease, cex.axis = 0.8)
+   ## order the rows by their mean effect
+   rowpos <- factor(rowpos,
+                    levels = sort.list(tapply(decrease, rowpos, mean)))
+   interaction.plot(rowpos, treatment, decrease, col = 2:9, lty = 1)
+ })
> 
> 
> 
> 
> cleanEx()
> nameEx("is.empty")
> ### * is.empty
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: is.empty.model
> ### Title: Test if a Model's Formula is Empty
> ### Aliases: is.empty.model
> ### Keywords: models
> 
> ### ** Examples
> 
> y <- rnorm(20)
> is.empty.model(y ~ 0)
[1] TRUE
> is.empty.model(y ~ -1)
[1] TRUE
> is.empty.model(lm(y ~ 0))
[1] TRUE
> 
> 
> 
> cleanEx()
> nameEx("isoreg")
> ### * isoreg
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: isoreg
> ### Title: Isotonic / Monotone Regression
> ### Aliases: isoreg
> ### Keywords: regression smooth
> 
> ### ** Examples
> 
> require(graphics)
> 
> (ir <- isoreg(c(1,0,4,3,3,5,4,2,0)))
Isotonic regression from isoreg(x = c(1, 0, 4, 3, 3, 5, 4, 2, 0)),
  with 2 knots / breaks at obs.nr. 2 9 ;
  initially ordered 'x'
  and further components List of 4
 $ x : num [1:9] 1 2 3 4 5 6 7 8 9
 $ y : num [1:9] 1 0 4 3 3 5 4 2 0
 $ yf: num [1:9] 0.5 0.5 3 3 3 3 3 3 3
 $ yc: num [1:10] 0 1 1 5 8 11 16 20 22 22
> plot(ir, plot.type = "row")
> 
> (ir3 <- isoreg(y3 <- c(1,0,4,3,3,5,4,2, 3))) # last "3", not "0"
Isotonic regression from isoreg(x = y3 <- c(1, 0, 4, 3, 3, 5, 4, 2, 3)),
  with 3 knots / breaks at obs.nr. 2 5 9 ;
  initially ordered 'x'
  and further components List of 4
 $ x : num [1:9] 1 2 3 4 5 6 7 8 9
 $ y : num [1:9] 1 0 4 3 3 5 4 2 3
 $ yf: num [1:9] 0.5 0.5 3.33 3.33 3.33 ...
 $ yc: num [1:10] 0 1 1 5 8 11 16 20 22 25
> (fi3 <- as.stepfun(ir3))
Step function
Call: isoreg(x = y3 <- c(1, 0, 4, 3, 3, 5, 4, 2, 3))
 x[1:3] =      2,      5,      9
4 plateau levels =    0.5,    0.5, 3.3333,    3.5
> (ir4 <- isoreg(1:10, y4 <- c(5, 9, 1:2, 5:8, 3, 8)))
Isotonic regression from isoreg(x = 1:10, y = y4 <- c(5, 9, 1:2, 5:8, 3, 8)),
  with 5 knots / breaks at obs.nr. 4 5 6 9 10 ;
  initially ordered 'x'
  and further components List of 4
 $ x : num [1:10] 1 2 3 4 5 6 7 8 9 10
 $ y : num [1:10] 5 9 1 2 5 6 7 8 3 8
 $ yf: num [1:10] 4.25 4.25 4.25 4.25 5 6 6 6 6 8
 $ yc: num [1:11] 0 5 14 15 17 22 28 35 43 46 ...
> cat(sprintf("R^2 = %.2f\n",
+             1 - sum(residuals(ir4)^2) / ((10-1)*var(y4))))
R^2 = 0.21
> 
> ## If you are interested in the knots alone :
> with(ir4, cbind(iKnots, yf[iKnots]))
     iKnots     
[1,]      4 4.25
[2,]      5 5.00
[3,]      6 6.00
[4,]      9 6.00
[5,]     10 8.00
> 
> ## Example of unordered x[] with ties:
> x <- sample((0:30)/8)
> y <- exp(x)
> x. <- round(x) # ties!
> plot(m <- isoreg(x., y))
> stopifnot(all.equal(with(m, yf[iKnots]),
+                     as.vector(tapply(y, x., mean))))
> 
> 
> 
> cleanEx()
> nameEx("kernapply")
> ### * kernapply
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: kernapply
> ### Title: Apply Smoothing Kernel
> ### Aliases: kernapply kernapply.default kernapply.ts kernapply.tskernel
> ###   kernapply.vector
> ### Keywords: ts
> 
> ### ** Examples
> 
> ## see 'kernel' for examples
> 
> 
> 
> cleanEx()
> nameEx("kernel")
> ### * kernel
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: kernel
> ### Title: Smoothing Kernel Objects
> ### Aliases: kernel bandwidth.kernel df.kernel is.tskernel plot.tskernel
> ### Keywords: ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## Demonstrate a simple trading strategy for the
> ## financial time series German stock index DAX.
> x <- EuStockMarkets[,1]
> k1 <- kernel("daniell", 50)  # a long moving average
> k2 <- kernel("daniell", 10)  # and a short one
> plot(k1)
> plot(k2)
> x1 <- kernapply(x, k1)
> x2 <- kernapply(x, k2)
> plot(x)
> lines(x1, col = "red")    # go long if the short crosses the long upwards
> lines(x2, col = "green")  # and go short otherwise
> 
> ## More interesting kernels
> kd <- kernel("daniell", c(3, 3))
> kd # note the unusual indexing
Daniell(3,3) 
coef[-6] = 0.02041
coef[-5] = 0.04082
coef[-4] = 0.06122
coef[-3] = 0.08163
coef[-2] = 0.10204
coef[-1] = 0.12245
coef[ 0] = 0.14286
coef[ 1] = 0.12245
coef[ 2] = 0.10204
coef[ 3] = 0.08163
coef[ 4] = 0.06122
coef[ 5] = 0.04082
coef[ 6] = 0.02041
> kd[-2:2]
[1] 0.1020408 0.1224490 0.1428571 0.1224490 0.1020408
> plot(kernel("fejer", 100, r = 6))
> plot(kernel("modified.daniell", c(7,5,3)))
> 
> # Reproduce example 10.4.3 from Brockwell and Davis (1991)
> spectrum(sunspot.year, kernel = kernel("daniell", c(11,7,3)), log = "no")
> 
> 
> 
> cleanEx()
> nameEx("kmeans")
> ### * kmeans
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: kmeans
> ### Title: K-Means Clustering
> ### Aliases: kmeans print.kmeans fitted.kmeans
> ### Keywords: multivariate cluster
> 
> ### ** Examples
> 
> require(graphics)
> 
> # a 2-dimensional example
> x <- rbind(matrix(rnorm(100, sd = 0.3), ncol = 2),
+            matrix(rnorm(100, mean = 1, sd = 0.3), ncol = 2))
> colnames(x) <- c("x", "y")
> (cl <- kmeans(x, 2))
K-means clustering with 2 clusters of sizes 49, 51

Cluster means:
           x          y
1 0.02149367 0.02121248
2 0.94443633 1.01712793

Clustering vector:
  [1] 1 1 1 1 1 1 1 1 1 1 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
 [38] 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
 [75] 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2

Within cluster sum of squares by cluster:
[1] 6.525480 8.392416
 (between_SS / total_SS =  75.5 %)

Available components:

[1] "cluster"      "centers"      "totss"        "withinss"     "tot.withinss"
[6] "betweenss"    "size"         "iter"         "ifault"      
> plot(x, col = cl$cluster)
> points(cl$centers, col = 1:2, pch = 8, cex = 2)
> 
> # sum of squares
> ss <- function(x) sum(scale(x, scale = FALSE)^2)
> 
> ## cluster centers "fitted" to each obs.:
> fitted.x <- fitted(cl);  head(fitted.x)
           x          y
1 0.02149367 0.02121248
1 0.02149367 0.02121248
1 0.02149367 0.02121248
1 0.02149367 0.02121248
1 0.02149367 0.02121248
1 0.02149367 0.02121248
> resid.x <- x - fitted(cl)
> 
> ## Equalities : ----------------------------------
> cbind(cl[c("betweenss", "tot.withinss", "totss")], # the same two columns
+          c(ss(fitted.x), ss(resid.x),    ss(x)))
             [,1]     [,2]    
betweenss    46.07333 46.07333
tot.withinss 14.9179  14.9179 
totss        60.99123 60.99123
> stopifnot(all.equal(cl$ totss,        ss(x)),
+ 	  all.equal(cl$ tot.withinss, ss(resid.x)),
+ 	  ## these three are the same:
+ 	  all.equal(cl$ betweenss,    ss(fitted.x)),
+ 	  all.equal(cl$ betweenss, cl$totss - cl$tot.withinss),
+ 	  ## and hence also
+ 	  all.equal(ss(x), ss(fitted.x) + ss(resid.x))
+ 	  )
> 
> kmeans(x,1)$withinss # trivial one-cluster, (its W.SS == ss(x))
[1] 60.99123
> 
> ## random starts do help here with too many clusters
> ## (and are often recommended anyway!):
> (cl <- kmeans(x, 5, nstart = 25))
K-means clustering with 5 clusters of sizes 12, 24, 24, 15, 25

Cluster means:
           x          y
1  1.3290081  1.1185534
2  0.1581362 -0.1761590
3  0.8043520  0.7805033
4  0.8609139  1.3145869
5 -0.1096832  0.2106891

Clustering vector:
  [1] 5 2 5 2 5 5 2 2 5 5 3 2 5 5 2 5 2 5 2 5 2 2 5 5 2 5 2 5 5 2 2 2 5 2 5 5 5
 [38] 2 2 2 2 5 5 5 5 5 2 2 2 2 4 3 3 3 3 1 1 1 3 1 4 3 1 4 3 4 3 3 1 4 4 1 4 3
 [75] 3 1 4 4 4 4 3 4 1 3 1 3 4 3 3 3 3 1 3 4 3 3 1 3 4 3

Within cluster sum of squares by cluster:
[1] 1.0314888 1.2816507 1.5056575 0.7104553 2.5330710
 (between_SS / total_SS =  88.4 %)

Available components:

[1] "cluster"      "centers"      "totss"        "withinss"     "tot.withinss"
[6] "betweenss"    "size"         "iter"         "ifault"      
> plot(x, col = cl$cluster)
> points(cl$centers, col = 1:5, pch = 8)
> 
> 
> 
> cleanEx()
> nameEx("kruskal.test")
> ### * kruskal.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: kruskal.test
> ### Title: Kruskal-Wallis Rank Sum Test
> ### Aliases: kruskal.test kruskal.test.default kruskal.test.formula
> ### Keywords: htest
> 
> ### ** Examples
> 
> ## Hollander & Wolfe (1973), 116.
> ## Mucociliary efficiency from the rate of removal of dust in normal
> ##  subjects, subjects with obstructive airway disease, and subjects
> ##  with asbestosis.
> x <- c(2.9, 3.0, 2.5, 2.6, 3.2) # normal subjects
> y <- c(3.8, 2.7, 4.0, 2.4)      # with obstructive airway disease
> z <- c(2.8, 3.4, 3.7, 2.2, 2.0) # with asbestosis
> kruskal.test(list(x, y, z))

	Kruskal-Wallis rank sum test

data:  list(x, y, z)
Kruskal-Wallis chi-squared = 0.77143, df = 2, p-value = 0.68

> ## Equivalently,
> x <- c(x, y, z)
> g <- factor(rep(1:3, c(5, 4, 5)),
+             labels = c("Normal subjects",
+                        "Subjects with obstructive airway disease",
+                        "Subjects with asbestosis"))
> kruskal.test(x, g)

	Kruskal-Wallis rank sum test

data:  x and g
Kruskal-Wallis chi-squared = 0.77143, df = 2, p-value = 0.68

> 
> ## Formula interface.
> require(graphics)
> boxplot(Ozone ~ Month, data = airquality)
> kruskal.test(Ozone ~ Month, data = airquality)

	Kruskal-Wallis rank sum test

data:  Ozone by Month
Kruskal-Wallis chi-squared = 29.267, df = 4, p-value = 6.901e-06

> 
> 
> 
> cleanEx()
> nameEx("ks.test")
> ### * ks.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Encoding: UTF-8
> 
> ### Name: ks.test
> ### Title: Kolmogorov-Smirnov Tests
> ### Aliases: ks.test ks.test.default ks.test.formula
> ### Keywords: htest
> 
> ### ** Examples
> 
> require("graphics")
> 
> x <- rnorm(50)
> y <- runif(30)
> # Do x and y come from the same distribution?
> ks.test(x, y)

	Exact two-sample Kolmogorov-Smirnov test

data:  x and y
D = 0.48, p-value = 0.0002033
alternative hypothesis: two-sided

> # Does x come from a shifted gamma distribution with shape 3 and rate 2?
> ks.test(x+2, "pgamma", 3, 2) # two-sided, exact

	Exact one-sample Kolmogorov-Smirnov test

data:  x + 2
D = 0.40962, p-value = 4.227e-08
alternative hypothesis: two-sided

> ks.test(x+2, "pgamma", 3, 2, exact = FALSE)

	Asymptotic one-sample Kolmogorov-Smirnov test

data:  x + 2
D = 0.40962, p-value = 1.033e-07
alternative hypothesis: two-sided

> ks.test(x+2, "pgamma", 3, 2, alternative = "gr")

	Exact one-sample Kolmogorov-Smirnov test

data:  x + 2
D^+ = 0.039998, p-value = 0.8302
alternative hypothesis: the CDF of x lies above the null hypothesis

> 
> # test if x is stochastically larger than x2
> x2 <- rnorm(50, -1)
> plot(ecdf(x), xlim = range(c(x, x2)))
> plot(ecdf(x2), add = TRUE, lty = "dashed")
> t.test(x, x2, alternative = "g")

	Welch Two Sample t-test

data:  x and x2
t = 5.6742, df = 96.85, p-value = 7.242e-08
alternative hypothesis: true difference in means is greater than 0
95 percent confidence interval:
 0.7069751       Inf
sample estimates:
 mean of x  mean of y 
 0.1004483 -0.8990693 

> wilcox.test(x, x2, alternative = "g")

	Wilcoxon rank sum test with continuity correction

data:  x and x2
W = 1983, p-value = 2.212e-07
alternative hypothesis: true location shift is greater than 0

> ks.test(x, x2, alternative = "l")

	Exact two-sample Kolmogorov-Smirnov test

data:  x and x2
D^- = 0.5, p-value = 2.404e-06
alternative hypothesis: the CDF of x lies below that of y

> 
> # with ties, example from Schröer and Trenkler (1995)
> # D = 3 / 7, p = 0.2424242
> ks.test(c(1, 2, 2, 3, 3), c(1, 2, 3, 3, 4, 5, 6), exact = TRUE)

	Exact two-sample Kolmogorov-Smirnov test

data:  c(1, 2, 2, 3, 3) and c(1, 2, 3, 3, 4, 5, 6)
D = 0.42857, p-value = 0.2424
alternative hypothesis: two-sided

> 
> # formula interface, see ?wilcox.test
> ks.test(Ozone ~ Month, data = airquality,
+         subset = Month %in% c(5, 8))

	Exact two-sample Kolmogorov-Smirnov test

data:  Ozone by Month
D = 0.53846, p-value = 0.0006919
alternative hypothesis: two-sided

> 
> 
> 
> cleanEx()
> nameEx("ksmooth")
> ### * ksmooth
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ksmooth
> ### Title: Kernel Regression Smoother
> ### Aliases: ksmooth
> ### Keywords: smooth
> 
> ### ** Examples
> 
> require(graphics)
> 
> with(cars, {
+     plot(speed, dist)
+     lines(ksmooth(speed, dist, "normal", bandwidth = 2), col = 2)
+     lines(ksmooth(speed, dist, "normal", bandwidth = 5), col = 3)
+ })
> 
> 
> 
> cleanEx()
> nameEx("lag")
> ### * lag
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: lag
> ### Title: Lag a Time Series
> ### Aliases: lag lag.default
> ### Keywords: ts
> 
> ### ** Examples
> 
> lag(ldeaths, 12) # starts one year earlier
      Jan  Feb  Mar  Apr  May  Jun  Jul  Aug  Sep  Oct  Nov  Dec
1973 3035 2552 2704 2554 2014 1655 1721 1524 1596 2074 2199 2512
1974 2933 2889 2938 2497 1870 1726 1607 1545 1396 1787 2076 2837
1975 2787 3891 3179 2011 1636 1580 1489 1300 1356 1653 2013 2823
1976 3102 2294 2385 2444 1748 1554 1498 1361 1346 1564 1640 2293
1977 2815 3137 2679 1969 1870 1633 1529 1366 1357 1570 1535 2491
1978 3084 2605 2573 2143 1693 1504 1461 1354 1333 1492 1781 1915
> 
> 
> 
> cleanEx()
> nameEx("lag.plot")
> ### * lag.plot
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: lag.plot
> ### Title: Time Series Lag Plots
> ### Aliases: lag.plot
> ### Keywords: hplot ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> lag.plot(nhtemp, 8, diag.col = "forest green")
> lag.plot(nhtemp, 5, main = "Average Temperatures in New Haven")
> ## ask defaults to TRUE when we have more than one page:
> lag.plot(nhtemp, 6, layout = c(2,1), asp = NA,
+          main = "New Haven Temperatures", col.main = "blue")
> 
> ## Multivariate (but non-stationary! ...)
> lag.plot(freeny.x, lags = 3)
> 
> ## no lines for long series :
> lag.plot(sqrt(sunspots), set.lags = c(1:4, 9:12), pch = ".", col = "gold")
> 
> 
> 
> cleanEx()
> nameEx("line")
> ### * line
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: line
> ### Title: Robust Line Fitting
> ### Aliases: line residuals.tukeyline
> ### Keywords: robust regression
> 
> ### ** Examples
> 
> require(graphics)
> 
> plot(cars)
> (z <- line(cars))

Call:
line(cars)

Coefficients:
[1]  -29.333    4.667

> abline(coef(z))
> ## Tukey-Anscombe Plot :
> plot(residuals(z) ~ fitted(z), main = deparse(z$call))
> 
> ## Andrew Siegel's pathological 9-point data, y-values multiplied by 3:
> d.AS <- data.frame(x = c(-4:3, 12), y = 3*c(rep(0,6), -5, 5, 1))
> cAS <- with(d.AS, t(sapply(1:10,
+                    function(it) line(x,y, iter=it)$coefficients)))
> dimnames(cAS) <- list(paste("it =", format(1:10)), c("intercept", "slope"))
> cAS
        intercept     slope
it =  1  0.500000  0.500000
it =  2 -0.250000 -0.250000
it =  3  0.875000  0.875000
it =  4 -0.812500 -0.812500
it =  5  1.718750  1.718750
it =  6 -2.078125 -2.078125
it =  7  2.500000  2.500000
it =  8 -2.083333 -2.083333
it =  9  2.500000  2.500000
it = 10 -2.083333 -2.083333
> ## iterations started to oscillate, repeating iteration 7,8 indefinitely
> 
> 
> 
> cleanEx()
> nameEx("lm")
> ### * lm
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: lm
> ### Title: Fitting Linear Models
> ### Aliases: lm print.lm
> ### Keywords: regression
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## Annette Dobson (1990) "An Introduction to Generalized Linear Models".
> ## Page 9: Plant Weight Data.
> 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, 20, labels = c("Ctl","Trt"))
> weight <- c(ctl, trt)
> lm.D9 <- lm(weight ~ group)
> lm.D90 <- lm(weight ~ group - 1) # omitting intercept
> opar <- par(mfrow = c(2,2), oma = c(0, 0, 1.1, 0))
> plot(lm.D9, las = 1)      # Residuals, Fitted, ...
> par(opar)
> ## Don't show: 
> ## model frame :
> stopifnot(identical(lm(weight ~ group, method = "model.frame"),
+                     model.frame(lm.D9)))
> ## End(Don't show)
> ### less simple examples in "See Also" above
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("lm.influence")
> ### * lm.influence
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: lm.influence
> ### Title: Regression Diagnostics
> ### Aliases: lm.influence influence influence.lm influence.glm
> ### Keywords: regression
> 
> ### ** Examples
> 
> ## Analysis of the life-cycle savings data
> ## given in Belsley, Kuh and Welsch.
> summary(lm.SR <- lm(sr ~ pop15 + pop75 + dpi + ddpi,
+                     data = LifeCycleSavings),
+         correlation = TRUE)

Call:
lm(formula = sr ~ pop15 + pop75 + dpi + ddpi, data = LifeCycleSavings)

Residuals:
    Min      1Q  Median      3Q     Max 
-8.2422 -2.6857 -0.2488  2.4280  9.7509 

Coefficients:
              Estimate Std. Error t value Pr(>|t|)    
(Intercept) 28.5660865  7.3545161   3.884 0.000334 ***
pop15       -0.4611931  0.1446422  -3.189 0.002603 ** 
pop75       -1.6914977  1.0835989  -1.561 0.125530    
dpi         -0.0003369  0.0009311  -0.362 0.719173    
ddpi         0.4096949  0.1961971   2.088 0.042471 *  
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 3.803 on 45 degrees of freedom
Multiple R-squared:  0.3385,	Adjusted R-squared:  0.2797 
F-statistic: 5.756 on 4 and 45 DF,  p-value: 0.0007904

Correlation of Coefficients:
      (Intercept) pop15 pop75 dpi  
pop15 -0.98                        
pop75 -0.81        0.77            
dpi   -0.17        0.18 -0.37      
ddpi  -0.19        0.10 -0.05  0.26

> utils::str(lmI <- lm.influence(lm.SR))
List of 4
 $ hat         : Named num [1:50] 0.0677 0.1204 0.0875 0.0895 0.0696 ...
  ..- attr(*, "names")= chr [1:50] "Australia" "Austria" "Belgium" "Bolivia" ...
 $ coefficients: num [1:50, 1:5] 0.0916 -0.0747 -0.4752 0.0429 0.6604 ...
  ..- attr(*, "dimnames")=List of 2
  .. ..$ : chr [1:50] "Australia" "Austria" "Belgium" "Bolivia" ...
  .. ..$ : chr [1:5] "(Intercept)" "pop15" "pop75" "dpi" ...
 $ sigma       : Named num [1:50] 3.84 3.84 3.83 3.84 3.81 ...
  ..- attr(*, "names")= chr [1:50] "Australia" "Austria" "Belgium" "Bolivia" ...
 $ wt.res      : Named num [1:50] 0.864 0.616 2.219 -0.698 3.553 ...
  ..- attr(*, "names")= chr [1:50] "Australia" "Austria" "Belgium" "Bolivia" ...
> 
> ## For more "user level" examples, use example(influence.measures)
> 
> 
> 
> cleanEx()
> nameEx("lm.summaries")
> ### * lm.summaries
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: lm.summaries
> ### Title: Accessing Linear Model Fits
> ### Aliases: family.lm formula.lm residuals.lm labels.lm
> ### Keywords: regression models
> 
> ### ** Examples
> 
> ## Don't show: 
> utils::example("lm", echo = FALSE)
> ## End(Don't show)
> ##-- Continuing the  lm(.) example:
> coef(lm.D90) # the bare coefficients
groupCtl groupTrt 
   5.032    4.661 
> 
> ## The 2 basic regression diagnostic plots [plot.lm(.) is preferred]
> plot(resid(lm.D90), fitted(lm.D90)) # Tukey-Anscombe's
> abline(h = 0, lty = 2, col = "gray")
> 
> qqnorm(residuals(lm.D90))
> 
> 
> 
> cleanEx()
> nameEx("lmfit")
> ### * lmfit
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: lm.fit
> ### Title: Fitter Functions for Linear Models
> ### Aliases: lm.fit lm.wfit .lm.fit
> ### Keywords: regression array
> 
> ### ** Examples
> 
> require(utils)
> set.seed(129)
> 
> n <- 7 ; p <- 2
> X <- matrix(rnorm(n * p), n, p) # no intercept!
> y <- rnorm(n)
> w <- rnorm(n)^2
> 
> str(lmw <- lm.wfit(x = X, y = y, w = w))
List of 9
 $ coefficients : Named num [1:2] -0.0432 -0.5612
  ..- attr(*, "names")= chr [1:2] "x1" "x2"
 $ residuals    : num [1:7] -0.132 -1.308 -0.256 1.468 0.439 ...
 $ fitted.values: num [1:7] 0.05 -0.5232 0.6151 -0.5766 0.0512 ...
 $ effects      : Named num [1:7] 0.804 1.722 -0.072 2.047 0.392 ...
  ..- attr(*, "names")= chr [1:7] "x1" "x2" "" "" ...
 $ weights      : num [1:7] 0.3195 0.0123 0.0569 1.8154 0.8359 ...
 $ rank         : int 2
 $ assign       : NULL
 $ qr           :List of 5
  ..$ qr   : num [1:7, 1:2] 3.0953 0.0355 0.106 0.5901 -0.5898 ...
  ..$ qraux: num [1:2] 1.2 1.02
  ..$ pivot: int [1:2] 1 2
  ..$ tol  : num 1e-07
  ..$ rank : int 2
  ..- attr(*, "class")= chr "qr"
 $ df.residual  : int 5
> 
> str(lm. <- lm.fit (x = X, y = y))
List of 8
 $ coefficients : Named num [1:2] 0.132 -0.553
  ..- attr(*, "names")= chr [1:2] "x1" "x2"
 $ residuals    : num [1:7] 0.06433 -1.14333 -0.00708 1.69606 0.09095 ...
 $ effects      : Named num [1:7] 0.791 1.476 -0.415 1.983 0.133 ...
  ..- attr(*, "names")= chr [1:7] "x1" "x2" "" "" ...
 $ rank         : int 2
 $ fitted.values: num [1:7] -0.146 -0.688 0.366 -0.804 0.399 ...
 $ assign       : NULL
 $ qr           :List of 5
  ..$ qr   : num [1:7, 1:2] 3.321 0.298 0.414 0.408 -0.601 ...
  ..$ qraux: num [1:2] 1.34 1.32
  ..$ pivot: int [1:2] 1 2
  ..$ tol  : num 1e-07
  ..$ rank : int 2
  ..- attr(*, "class")= chr "qr"
 $ df.residual  : int 5
> ## Don't show: 
>   ## These are the same calculations at C level, but a parallel BLAS
>   ## might not do them the same way twice, and if seems serial MKL does not.
>   lm.. <- .lm.fit(X,y)
>   lm.w <- .lm.fit(X*sqrt(w), y*sqrt(w))
>   id <- function(x, y) all.equal(x, y, tolerance = 1e-15, scale = 1)
>   stopifnot(id(unname(lm.$coef), lm..$coef),
+ 	    id(unname(lmw$coef), lm.w$coef))
> ## End(Don't show)
> 
> 
> 
> cleanEx()
> nameEx("loess")
> ### * loess
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: loess
> ### Title: Local Polynomial Regression Fitting
> ### Aliases: loess
> ### Keywords: smooth loess
> 
> ### ** Examples
> 
> cars.lo <- loess(dist ~ speed, cars)
> predict(cars.lo, data.frame(speed = seq(5, 30, 1)), se = TRUE)
$fit
        1         2         3         4         5         6         7         8 
 7.797353 10.002308 12.499786 15.281082 18.446568 21.865315 25.517015 29.350386 
        9        10        11        12        13        14        15        16 
33.230660 37.167935 41.205226 45.055736 48.355889 49.824812 51.986702 56.461318 
       17        18        19        20        21        22        23        24 
61.959729 68.569313 76.316068 85.212121 95.324047        NA        NA        NA 
       25        26 
       NA        NA 

$se.fit
       1        2        3        4        5        6        7        8 
7.568120 5.945831 4.990827 4.545284 4.308639 4.115049 3.789542 3.716231 
       9       10       11       12       13       14       15       16 
3.776947 4.091747 4.709568 4.245427 4.035929 3.753410 4.004705 4.043190 
      17       18       19       20       21       22       23       24 
4.026105 4.074664 4.570818 5.954217 8.302014       NA       NA       NA 
      25       26 
      NA       NA 

$residual.scale
[1] 15.29496

$df
[1] 44.6179

> # to allow extrapolation
> cars.lo2 <- loess(dist ~ speed, cars,
+   control = loess.control(surface = "direct"))
> predict(cars.lo2, data.frame(speed = seq(5, 30, 1)), se = TRUE)
$fit
         1          2          3          4          5          6          7 
  7.741006   9.926596  12.442424  15.281082  18.425712  21.865315  25.713413 
         8          9         10         11         12         13         14 
 29.350386  33.230660  37.167935  41.205226  45.781544  48.355889  50.067148 
        15         16         17         18         19         20         21 
 51.986702  56.445263  62.025404  68.569313  76.193111  85.053364  95.300523 
        22         23         24         25         26 
106.974661 120.092581 134.665851 150.698545 168.190283 

$se.fit
        1         2         3         4         5         6         7         8 
 7.565991  5.959097  5.012013  4.550013  4.321596  4.119331  3.939804  3.720098 
        9        10        11        12        13        14        15        16 
 3.780877  4.096004  4.714469  4.398936  4.040129  4.184257  4.008873  4.061865 
       17        18        19        20        21        22        23        24 
 4.033998  4.078904  4.584606  5.952480  8.306901 11.601911 15.792480 20.864660 
       25        26 
26.823827 33.683999 

$residual.scale
[1] 15.31087

$df
[1] 44.55085

> 
> 
> 
> cleanEx()
> nameEx("logLik")
> ### * logLik
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: logLik
> ### Title: Extract Log-Likelihood
> ### Aliases: logLik logLik.lm
> ### Keywords: models
> 
> ### ** Examples
> 
> x <- 1:5
> lmx <- lm(x ~ 1)
> logLik(lmx) # using print.logLik() method
'log Lik.' -8.827561 (df=2)
> utils::str(logLik(lmx))
Class 'logLik' : -8.828 (df=2)
> 
> ## lm method
> (fm1 <- lm(rating ~ ., data = attitude))

Call:
lm(formula = rating ~ ., data = attitude)

Coefficients:
(Intercept)   complaints   privileges     learning       raises     critical  
   10.78708      0.61319     -0.07305      0.32033      0.08173      0.03838  
    advance  
   -0.21706  

> logLik(fm1)
'log Lik.' -97.24991 (df=8)
> logLik(fm1, REML = TRUE)
'log Lik.' -102.6851 (df=8)
> 
> 
> 
> cleanEx()
> nameEx("loglin")
> ### * loglin
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: loglin
> ### Title: Fitting Log-Linear Models
> ### Aliases: loglin
> ### Keywords: category models
> 
> ### ** Examples
> 
> ## Model of joint independence of sex from hair and eye color.
> fm <- loglin(HairEyeColor, list(c(1, 2), c(1, 3), c(2, 3)))
5 iterations: deviation 0.04093795 
> fm
$lrt
[1] 6.761258

$pearson
[1] 6.868292

$df
[1] 9

$margin
$margin[[1]]
[1] "Hair" "Eye" 

$margin[[2]]
[1] "Hair" "Sex" 

$margin[[3]]
[1] "Eye" "Sex"


> 1 - pchisq(fm$lrt, fm$df)
[1] 0.66196
> ## Model with no three-factor interactions fits well.
> 
> 
> 
> cleanEx()
> nameEx("lowess")
> ### * lowess
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: lowess
> ### Title: Scatter Plot Smoothing
> ### Aliases: lowess
> ### Keywords: smooth
> 
> ### ** Examples
> 
> require(graphics)
> 
> plot(cars, main = "lowess(cars)")
> lines(lowess(cars), col = 2)
> lines(lowess(cars, f = .2), col = 3)
> legend(5, 120, c(paste("f = ", c("2/3", ".2"))), lty = 1, col = 2:3)
> 
> 
> 
> cleanEx()
> nameEx("ls.diag")
> ### * ls.diag
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ls.diag
> ### Title: Compute Diagnostics for 'lsfit' Regression Results
> ### Aliases: ls.diag
> ### Keywords: regression
> 
> ### ** Examples
> 
> ## Don't show: 
> utils::example("lm", echo = FALSE)
> ## End(Don't show)
> ##-- Using the same data as the lm(.) example:
> lsD9 <- lsfit(x = as.numeric(gl(2, 10, 20)), y = weight)
> dlsD9 <- ls.diag(lsD9)
> abs(1 - sum(dlsD9$hat) / 2) < 10*.Machine$double.eps # sum(h.ii) = p
[1] TRUE
> plot(dlsD9$hat, dlsD9$stud.res, xlim = c(0, 0.11))
> abline(h = 0, lty = 2, col = "lightgray")
> 
> 
> 
> cleanEx()
> nameEx("lsfit")
> ### * lsfit
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: lsfit
> ### Title: Find the Least Squares Fit
> ### Aliases: lsfit
> ### Keywords: regression
> 
> ### ** Examples
> 
> ## Don't show: 
> utils::example("lm", echo = FALSE)
> ## End(Don't show)
> ##-- Using the same data as the lm(.) example:
> lsD9 <- lsfit(x = unclass(gl(2, 10)), y = weight)
> ls.print(lsD9)
Residual Standard Error=0.6964
R-Square=0.0731
F-statistic (df=1, 18)=1.4191
p-value=0.249

          Estimate Std.Err t-value Pr(>|t|)
Intercept    5.403  0.4924 10.9723    0.000
X           -0.371  0.3114 -1.1913    0.249


> 
> 
> 
> cleanEx()
> nameEx("mad")
> ### * mad
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: mad
> ### Title: Median Absolute Deviation
> ### Aliases: mad
> ### Keywords: univar robust
> 
> ### ** Examples
> 
> mad(c(1:9))
[1] 2.9652
> print(mad(c(1:9),     constant = 1)) ==
+       mad(c(1:8, 100), constant = 1)       # = 2 ; TRUE
[1] 2
[1] TRUE
> x <- c(1,2,3,5,7,8)
> sort(abs(x - median(x)))
[1] 1 1 2 3 3 4
> c(mad(x, constant = 1),
+   mad(x, constant = 1, low = TRUE),
+   mad(x, constant = 1, high = TRUE))
[1] 2.5 2.0 3.0
> 
> 
> 
> cleanEx()
> nameEx("mahalanobis")
> ### * mahalanobis
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: mahalanobis
> ### Title: Mahalanobis Distance
> ### Aliases: mahalanobis
> ### Keywords: multivariate
> 
> ### ** Examples
> 
> require(graphics)
> 
> ma <- cbind(1:6, 1:3)
> (S <-  var(ma))
     [,1] [,2]
[1,]  3.5  0.8
[2,]  0.8  0.8
> mahalanobis(c(0, 0), 1:2, S)
[1] 5.37037
> 
> x <- matrix(rnorm(100*3), ncol = 3)
> stopifnot(mahalanobis(x, 0, diag(ncol(x))) == rowSums(x*x))
>         ##- Here, D^2 = usual squared Euclidean distances
> 
> Sx <- cov(x)
> D2 <- mahalanobis(x, colMeans(x), Sx)
> plot(density(D2, bw = 0.5),
+      main="Squared Mahalanobis distances, n=100, p=3") ; rug(D2)
> qqplot(qchisq(ppoints(100), df = 3), D2,
+        main = expression("Q-Q plot of Mahalanobis" * ~D^2 *
+                          " vs. quantiles of" * ~ chi[3]^2))
> abline(0, 1, col = 'gray')
> 
> 
> 
> cleanEx()
> nameEx("make.link")
> ### * make.link
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: make.link
> ### Title: Create a Link for GLM Families
> ### Aliases: make.link
> ### Keywords: models
> 
> ### ** Examples
> 
> utils::str(make.link("logit"))
List of 5
 $ linkfun :function (mu)  
 $ linkinv :function (eta)  
 $ mu.eta  :function (eta)  
 $ valideta:function (eta)  
 $ name    : chr "logit"
 - attr(*, "class")= chr "link-glm"
> 
> 
> 
> cleanEx()
> nameEx("makepredictcall")
> ### * makepredictcall
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: makepredictcall
> ### Title: Utility Function for Safe Prediction
> ### Aliases: makepredictcall makepredictcall.default SafePrediction
> ### Keywords: models
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## using poly: this did not work in R < 1.5.0
> fm <- lm(weight ~ poly(height, 2), data = women)
> plot(women, xlab = "Height (in)", ylab = "Weight (lb)")
> ht <- seq(57, 73, length.out = 200)
> nD <- data.frame(height = ht)
> pfm <- predict(fm, nD)
> lines(ht, pfm)
> pf2 <- predict(update(fm, ~ stats::poly(height, 2)), nD)
> stopifnot(all.equal(pfm, pf2)) ## was off (rel.diff. 0.0766) in R <= 3.5.0
> 
> ## see also example(cars)
> 
> ## see bs and ns for spline examples.
> 
> 
> 
> cleanEx()
> nameEx("manova")
> ### * manova
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: manova
> ### Title: Multivariate Analysis of Variance
> ### Aliases: manova
> ### Keywords: models
> 
> ### ** Examples
> 
> ## Set orthogonal contrasts.
> op <- options(contrasts = c("contr.helmert", "contr.poly"))
> 
> ## Fake a 2nd response variable
> npk2 <- within(npk, foo <- rnorm(24))
> ( npk2.aov <- manova(cbind(yield, foo) ~ block + N*P*K, npk2) )
Call:
   manova(cbind(yield, foo) ~ block + N * P * K, npk2)

Terms:
                   block        N        P        K      N:P      N:K      P:K
yield           343.2950 189.2817   8.4017  95.2017  21.2817  33.1350   0.4817
foo               2.9548   0.0223   1.3807   0.0097   2.7585   0.9724   5.5258
Deg. of Freedom        5        1        1        1        1        1        1
                Residuals
yield            185.2867
foo                7.8286
Deg. of Freedom        12

Residual standard errors: 3.929447 0.8077039
1 out of 13 effects not estimable
Estimated effects are balanced
> summary(npk2.aov)
          Df  Pillai approx F num Df den Df  Pr(>F)  
block      5 0.89478   1.9430     10     24 0.08861 .
N          1 0.50586   5.6304      2     11 0.02071 *
P          1 0.17088   1.1336      2     11 0.35677  
K          1 0.34430   2.8879      2     11 0.09815 .
N:P        1 0.30158   2.3750      2     11 0.13888  
N:K        1 0.21654   1.5201      2     11 0.26127  
P:K        1 0.41992   3.9814      2     11 0.05003 .
Residuals 12                                         
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
> 
> ( npk2.aovE <- manova(cbind(yield, foo) ~  N*P*K + Error(block), npk2) )

Call:
manova(cbind(yield, foo) ~ N * P * K + Error(block), npk2)

Grand Means:
     yield        foo 
54.8750000  0.1498669 

Stratum 1: block

Terms:
                    N:P:K Residuals
yield            37.00167 306.29333
foo               0.06988   2.88496
Deg. of Freedom         1         4

Residual standard errors: 8.750619 0.8492579
Estimated effects are balanced

Stratum 2: Within

Terms:
                        N         P         K       N:P       N:K       P:K
yield           189.28167   8.40167  95.20167  21.28167  33.13500   0.48167
foo               0.02235   1.38066   0.00966   2.75852   0.97240   5.52584
Deg. of Freedom         1         1         1         1         1         1
                Residuals
yield           185.28667
foo               7.82863
Deg. of Freedom        12

Residual standard errors: 3.929447 0.8077039
Estimated effects are balanced
> summary(npk2.aovE)

Error: block
          Df  Pillai approx F num Df den Df Pr(>F)
N:P:K      1 0.20004   0.3751      2      3 0.7155
Residuals  4                                      

Error: Within
          Df  Pillai approx F num Df den Df  Pr(>F)  
N          1 0.50586   5.6304      2     11 0.02071 *
P          1 0.17088   1.1336      2     11 0.35677  
K          1 0.34430   2.8879      2     11 0.09815 .
N:P        1 0.30158   2.3750      2     11 0.13888  
N:K        1 0.21654   1.5201      2     11 0.26127  
P:K        1 0.41992   3.9814      2     11 0.05003 .
Residuals 12                                         
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
> 
> 
> 
> base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
> cleanEx()
> nameEx("mantelhaen.test")
> ### * mantelhaen.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: mantelhaen.test
> ### Title: Cochran-Mantel-Haenszel Chi-Squared Test for Count Data
> ### Aliases: mantelhaen.test
> ### Keywords: htest
> 
> ### ** Examples
> 
> ## Agresti (1990), pages 231--237, Penicillin and Rabbits
> ## Investigation of the effectiveness of immediately injected or 1.5
> ##  hours delayed penicillin in protecting rabbits against a lethal
> ##  injection with beta-hemolytic streptococci.
> Rabbits <-
+ array(c(0, 0, 6, 5,
+         3, 0, 3, 6,
+         6, 2, 0, 4,
+         5, 6, 1, 0,
+         2, 5, 0, 0),
+       dim = c(2, 2, 5),
+       dimnames = list(
+           Delay = c("None", "1.5h"),
+           Response = c("Cured", "Died"),
+           Penicillin.Level = c("1/8", "1/4", "1/2", "1", "4")))
> Rabbits
, , Penicillin.Level = 1/8

      Response
Delay  Cured Died
  None     0    6
  1.5h     0    5

, , Penicillin.Level = 1/4

      Response
Delay  Cured Died
  None     3    3
  1.5h     0    6

, , Penicillin.Level = 1/2

      Response
Delay  Cured Died
  None     6    0
  1.5h     2    4

, , Penicillin.Level = 1

      Response
Delay  Cured Died
  None     5    1
  1.5h     6    0

, , Penicillin.Level = 4

      Response
Delay  Cured Died
  None     2    0
  1.5h     5    0

> ## Classical Mantel-Haenszel test
> mantelhaen.test(Rabbits)

	Mantel-Haenszel chi-squared test with continuity correction

data:  Rabbits
Mantel-Haenszel X-squared = 3.9286, df = 1, p-value = 0.04747
alternative hypothesis: true common odds ratio is not equal to 1
95 percent confidence interval:
  1.026713 47.725133
sample estimates:
common odds ratio 
                7 

> ## => p = 0.047, some evidence for higher cure rate of immediate
> ##               injection
> ## Exact conditional test
> mantelhaen.test(Rabbits, exact = TRUE)

	Exact conditional test of independence in 2 x 2 x k tables

data:  Rabbits
S = 16, p-value = 0.03994
alternative hypothesis: true common odds ratio is not equal to 1
95 percent confidence interval:
   1.077401 529.837399
sample estimates:
common odds ratio 
         10.36102 

> ## => p - 0.040
> ## Exact conditional test for one-sided alternative of a higher
> ## cure rate for immediate injection
> mantelhaen.test(Rabbits, exact = TRUE, alternative = "greater")

	Exact conditional test of independence in 2 x 2 x k tables

data:  Rabbits
S = 16, p-value = 0.01997
alternative hypothesis: true common odds ratio is greater than 1
95 percent confidence interval:
 1.384239      Inf
sample estimates:
common odds ratio 
         10.36102 

> ## => p = 0.020
> 
> ## UC Berkeley Student Admissions
> mantelhaen.test(UCBAdmissions)

	Mantel-Haenszel chi-squared test with continuity correction

data:  UCBAdmissions
Mantel-Haenszel X-squared = 1.4269, df = 1, p-value = 0.2323
alternative hypothesis: true common odds ratio is not equal to 1
95 percent confidence interval:
 0.7719074 1.0603298
sample estimates:
common odds ratio 
        0.9046968 

> ## No evidence for association between admission and gender
> ## when adjusted for department.  However,
> apply(UCBAdmissions, 3, function(x) (x[1,1]*x[2,2])/(x[1,2]*x[2,1]))
        A         B         C         D         E         F 
0.3492120 0.8025007 1.1330596 0.9212838 1.2216312 0.8278727 
> ## This suggests that the assumption of homogeneous (conditional)
> ## odds ratios may be violated.  The traditional approach would be
> ## using the Woolf test for interaction:
> woolf <- function(x) {
+   x <- x + 1 / 2
+   k <- dim(x)[3]
+   or <- apply(x, 3, function(x) (x[1,1]*x[2,2])/(x[1,2]*x[2,1]))
+   w <-  apply(x, 3, function(x) 1 / sum(1 / x))
+   1 - pchisq(sum(w * (log(or) - weighted.mean(log(or), w)) ^ 2), k - 1)
+ }
> woolf(UCBAdmissions)
[1] 0.0034272
> ## => p = 0.003, indicating that there is significant heterogeneity.
> ## (And hence the Mantel-Haenszel test cannot be used.)
> 
> ## Agresti (2002), p. 287f and p. 297.
> ## Job Satisfaction example.
> Satisfaction <-
+     as.table(array(c(1, 2, 0, 0, 3, 3, 1, 2,
+                      11, 17, 8, 4, 2, 3, 5, 2,
+                      1, 0, 0, 0, 1, 3, 0, 1,
+                      2, 5, 7, 9, 1, 1, 3, 6),
+                    dim = c(4, 4, 2),
+                    dimnames =
+                    list(Income =
+                         c("<5000", "5000-15000",
+                           "15000-25000", ">25000"),
+                         "Job Satisfaction" =
+                         c("V_D", "L_S", "M_S", "V_S"),
+                         Gender = c("Female", "Male"))))
> ## (Satisfaction categories abbreviated for convenience.)
> ftable(. ~ Gender + Income, Satisfaction)
                   Job Satisfaction V_D L_S M_S V_S
Gender Income                                      
Female <5000                          1   3  11   2
       5000-15000                     2   3  17   3
       15000-25000                    0   1   8   5
       >25000                         0   2   4   2
Male   <5000                          1   1   2   1
       5000-15000                     0   3   5   1
       15000-25000                    0   0   7   3
       >25000                         0   1   9   6
> ## Table 7.8 in Agresti (2002), p. 288.
> mantelhaen.test(Satisfaction)

	Cochran-Mantel-Haenszel test

data:  Satisfaction
Cochran-Mantel-Haenszel M^2 = 10.2, df = 9, p-value = 0.3345

> ## See Table 7.12 in Agresti (2002), p. 297.
> 
> 
> 
> cleanEx()
> nameEx("mauchly.test")
> ### * mauchly.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: mauchly.test
> ### Title: Mauchly's Test of Sphericity
> ### Aliases: mauchly.test mauchly.test.SSD mauchly.test.mlm
> ### Keywords: htest models multivariate
> 
> ### ** Examples
> 
> utils::example(SSD) # Brings in the mlmfit and reacttime objects

SSD> # Lifted from Baron+Li:
SSD> # "Notes on the use of R for psychology experiments and questionnaires"
SSD> # Maxwell and Delaney, p. 497
SSD> reacttime <- matrix(c(
SSD+ 420, 420, 480, 480, 600, 780,
SSD+ 420, 480, 480, 360, 480, 600,
SSD+ 480, 480, 540, 660, 780, 780,
SSD+ 420, 540, 540, 480, 780, 900,
SSD+ 540, 660, 540, 480, 660, 720,
SSD+ 360, 420, 360, 360, 480, 540,
SSD+ 480, 480, 600, 540, 720, 840,
SSD+ 480, 600, 660, 540, 720, 900,
SSD+ 540, 600, 540, 480, 720, 780,
SSD+ 480, 420, 540, 540, 660, 780),
SSD+ ncol = 6, byrow = TRUE,
SSD+ dimnames = list(subj = 1:10,
SSD+               cond = c("deg0NA", "deg4NA", "deg8NA",
SSD+                        "deg0NP", "deg4NP", "deg8NP")))

SSD> mlmfit <- lm(reacttime ~ 1)

SSD> SSD(mlmfit)
$SSD
        cond
cond     deg0NA deg4NA deg8NA deg0NP deg4NP deg8NP
  deg0NA  29160  30600  26640  23760  32400  25560
  deg4NA  30600  66600  32400   7200  36000  30600
  deg8NA  26640  32400  56160  41040  57600  69840
  deg0NP  23760   7200  41040  70560  72000  63360
  deg4NP  32400  36000  57600  72000 108000 100800
  deg8NP  25560  30600  69840  63360 100800 122760

$call
lm(formula = reacttime ~ 1)

$df
[1] 9

attr(,"class")
[1] "SSD"

SSD> estVar(mlmfit)
        cond
cond     deg0NA deg4NA deg8NA deg0NP deg4NP deg8NP
  deg0NA   3240   3400   2960   2640   3600   2840
  deg4NA   3400   7400   3600    800   4000   3400
  deg8NA   2960   3600   6240   4560   6400   7760
  deg0NP   2640    800   4560   7840   8000   7040
  deg4NP   3600   4000   6400   8000  12000  11200
  deg8NP   2840   3400   7760   7040  11200  13640
> 
> ### traditional test of intrasubj. contrasts
> mauchly.test(mlmfit, X = ~1)

	Mauchly's test of sphericity
	Contrasts orthogonal to
	~1


data:  SSD matrix from lm(formula = reacttime ~ 1)
W = 0.031084, p-value = 0.04765

> 
> ### tests using intra-subject 3x2 design
> idata <- data.frame(deg = gl(3, 1, 6, labels = c(0,4,8)),
+                     noise = gl(2, 3, 6, labels = c("A","P")))
> mauchly.test(mlmfit, X = ~ deg + noise, idata = idata)

	Mauchly's test of sphericity
	Contrasts orthogonal to
	~deg + noise


data:  SSD matrix from lm(formula = reacttime ~ 1)
W = 0.89378, p-value = 0.6381

> mauchly.test(mlmfit, M = ~ deg + noise, X = ~ noise, idata = idata)

	Mauchly's test of sphericity
	Contrasts orthogonal to
	~noise

	Contrasts spanned by
	~deg + noise


data:  SSD matrix from lm(formula = reacttime ~ 1)
W = 0.96011, p-value = 0.8497

> 
> 
> 
> cleanEx()
> nameEx("mcnemar.test")
> ### * mcnemar.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: mcnemar.test
> ### Title: McNemar's Chi-squared Test for Count Data
> ### Aliases: mcnemar.test
> ### Keywords: htest
> 
> ### ** Examples
> 
> ## Agresti (1990), p. 350.
> ## Presidential Approval Ratings.
> ##  Approval of the President's performance in office in two surveys,
> ##  one month apart, for a random sample of 1600 voting-age Americans.
> Performance <-
+ matrix(c(794, 86, 150, 570),
+        nrow = 2,
+        dimnames = list("1st Survey" = c("Approve", "Disapprove"),
+                        "2nd Survey" = c("Approve", "Disapprove")))
> Performance
            2nd Survey
1st Survey   Approve Disapprove
  Approve        794        150
  Disapprove      86        570
> mcnemar.test(Performance)

	McNemar's Chi-squared test with continuity correction

data:  Performance
McNemar's chi-squared = 16.818, df = 1, p-value = 4.115e-05

> ## => significant change (in fact, drop) in approval ratings
> 
> 
> 
> cleanEx()
> nameEx("median")
> ### * median
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: median
> ### Title: Median Value
> ### Aliases: median median.default
> ### Keywords: univar robust
> 
> ### ** Examples
> 
> median(1:4)                # = 2.5 [even number]
[1] 2.5
> median(c(1:3, 100, 1000))  # = 3 [odd, robust]
[1] 3
> 
> 
> 
> cleanEx()
> nameEx("medpolish")
> ### * medpolish
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: medpolish
> ### Title: Median Polish (Robust Twoway Decomposition) of a Matrix
> ### Aliases: medpolish
> ### Keywords: robust
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## Deaths from sport parachuting;  from ABC of EDA, p.224:
> deaths <-
+     rbind(c(14,15,14),
+           c( 7, 4, 7),
+           c( 8, 2,10),
+           c(15, 9,10),
+           c( 0, 2, 0))
> dimnames(deaths) <- list(c("1-24", "25-74", "75-199", "200++", "NA"),
+                          paste(1973:1975))
> deaths
       1973 1974 1975
1-24     14   15   14
25-74     7    4    7
75-199    8    2   10
200++    15    9   10
NA        0    2    0
> (med.d <- medpolish(deaths))
1: 19
Final: 19

Median Polish Results (Dataset: "deaths")

Overall: 8

Row Effects:
  1-24  25-74 75-199  200++     NA 
     6     -1      0      2     -8 

Column Effects:
1973 1974 1975 
   0   -1    0 

Residuals:
       1973 1974 1975
1-24      0    2    0
25-74     0   -2    0
75-199    0   -5    2
200++     5    0    0
NA        0    3    0

> plot(med.d)
> ## Check decomposition:
> all(deaths ==
+     med.d$overall + outer(med.d$row,med.d$col, `+`) + med.d$residuals)
[1] TRUE
> 
> 
> 
> cleanEx()
> nameEx("model.extract")
> ### * model.extract
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: model.extract
> ### Title: Extract Components from a Model Frame
> ### Aliases: model.extract model.offset model.response model.weights
> ### Keywords: manip programming models
> 
> ### ** Examples
> 
> a <- model.frame(cbind(ncases,ncontrols) ~ agegp + tobgp + alcgp, data = esoph)
> model.extract(a, "response")
   ncases ncontrols
1       0        40
2       0        10
3       0         6
4       0         5
5       0        27
6       0         7
7       0         4
8       0         7
9       0         2
10      0         1
11      0         2
12      0         1
13      1         0
14      0         1
15      0         2
16      0        60
17      1        13
18      0         7
19      0         8
20      0        35
21      3        20
22      1        13
23      0         8
24      0        11
25      0         6
26      0         2
27      0         1
28      2         1
29      0         3
30      2         2
31      1        45
32      0        18
33      0        10
34      0         4
35      6        32
36      4        17
37      5        10
38      5         2
39      3        13
40      6         8
41      1         4
42      2         2
43      4         0
44      3         1
45      2         1
46      4         0
47      2        47
48      3        19
49      3         9
50      4         2
51      9        31
52      6        15
53      4        13
54      3         3
55      9         9
56      8         7
57      3         3
58      4         0
59      5         5
60      6         1
61      2         1
62      5         1
63      5        43
64      4        10
65      2         5
66      0         2
67     17        17
68      3         7
69      5         4
70      6         7
71      4         8
72      2         1
73      1         0
74      3         1
75      1         1
76      1         0
77      1         0
78      1        17
79      2         4
80      1         2
81      2         3
82      1         2
83      0         3
84      1         0
85      1         0
86      1         0
87      2         0
88      1         0
> stopifnot(model.extract(a, "response") == model.response(a))
> 
> a <- model.frame(ncases/(ncases+ncontrols) ~ agegp + tobgp + alcgp,
+                  data = esoph, weights = ncases+ncontrols)
> model.response(a)
         1          2          3          4          5          6          7 
0.00000000 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000 
         8          9         10         11         12         13         14 
0.00000000 0.00000000 0.00000000 0.00000000 0.00000000 1.00000000 0.00000000 
        15         16         17         18         19         20         21 
0.00000000 0.00000000 0.07142857 0.00000000 0.00000000 0.00000000 0.13043478 
        22         23         24         25         26         27         28 
0.07142857 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000 0.66666667 
        29         30         31         32         33         34         35 
0.00000000 0.50000000 0.02173913 0.00000000 0.00000000 0.00000000 0.15789474 
        36         37         38         39         40         41         42 
0.19047619 0.33333333 0.71428571 0.18750000 0.42857143 0.20000000 0.50000000 
        43         44         45         46         47         48         49 
1.00000000 0.75000000 0.66666667 1.00000000 0.04081633 0.13636364 0.25000000 
        50         51         52         53         54         55         56 
0.66666667 0.22500000 0.28571429 0.23529412 0.50000000 0.50000000 0.53333333 
        57         58         59         60         61         62         63 
0.50000000 1.00000000 0.50000000 0.85714286 0.66666667 0.83333333 0.10416667 
        64         65         66         67         68         69         70 
0.28571429 0.28571429 0.00000000 0.50000000 0.30000000 0.55555556 0.46153846 
        71         72         73         74         75         76         77 
0.33333333 0.66666667 1.00000000 0.75000000 0.50000000 1.00000000 1.00000000 
        78         79         80         81         82         83         84 
0.05555556 0.33333333 0.33333333 0.40000000 0.33333333 0.00000000 1.00000000 
        85         86         87         88 
1.00000000 1.00000000 1.00000000 1.00000000 
> (mw <- model.extract(a, "weights"))
 1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 
40 10  6  5 27  7  4  7  2  1  2  1  1  1  2 60 14  7  8 35 23 14  8 11  6  2 
27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 
 1  3  3  4 46 18 10  4 38 21 15  7 16 14  5  4  4  4  3  4 49 22 12  6 40 21 
53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 
17  6 18 15  6  4 10  7  3  6 48 14  7  2 34 10  9 13 12  3  1  4  2  1  1 18 
79 80 81 82 83 84 85 86 87 88 
 6  3  5  3  3  1  1  1  2  1 
> stopifnot(identical(unname(mw), model.weights(a)))
> 
> a <- model.frame(cbind(ncases,ncontrols) ~ agegp,
+                  something = tobgp, data = esoph)
> names(a)
[1] "cbind(ncases, ncontrols)" "agegp"                   
[3] "(something)"             
> stopifnot(model.extract(a, "something") == esoph$tobgp)
> 
> 
> 
> cleanEx()
> nameEx("model.frame")
> ### * model.frame
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: model.frame
> ### Title: Extracting the Model Frame from a Formula or Fit
> ### Aliases: model.frame model.frame.default model.frame.lm model.frame.glm
> ###   model.frame.aovlist get_all_vars
> ### Keywords: models
> 
> ### ** Examples
> 
> data.class(model.frame(dist ~ speed, data = cars))
[1] "data.frame"
> 
> ## get_all_vars(): new var.s are recycled (iff length matches: 50 = 2*25)
> ncars <- get_all_vars(sqrt(dist) ~ I(speed/2), data = cars, newVar = 2:3)
> stopifnot(is.data.frame(ncars),
+           identical(cars, ncars[,names(cars)]),
+           ncol(ncars) == ncol(cars) + 1)
> 
> 
> 
> cleanEx()
> nameEx("model.matrix")
> ### * model.matrix
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: model.matrix
> ### Title: Construct Design Matrices
> ### Aliases: model.matrix model.matrix.default model.matrix.lm
> ### Keywords: models
> 
> ### ** Examples
> 
> ff <- log(Volume) ~ log(Height) + log(Girth)
> utils::str(m <- model.frame(ff, trees))
'data.frame':	31 obs. of  3 variables:
 $ log(Volume): num  2.33 2.33 2.32 2.8 2.93 ...
 $ log(Height): num  4.25 4.17 4.14 4.28 4.39 ...
 $ log(Girth) : num  2.12 2.15 2.17 2.35 2.37 ...
 - attr(*, "terms")=Classes 'terms', 'formula'  language log(Volume) ~ log(Height) + log(Girth)
  .. ..- attr(*, "variables")= language list(log(Volume), log(Height), log(Girth))
  .. ..- attr(*, "factors")= int [1:3, 1:2] 0 1 0 0 0 1
  .. .. ..- attr(*, "dimnames")=List of 2
  .. .. .. ..$ : chr [1:3] "log(Volume)" "log(Height)" "log(Girth)"
  .. .. .. ..$ : chr [1:2] "log(Height)" "log(Girth)"
  .. ..- attr(*, "term.labels")= chr [1:2] "log(Height)" "log(Girth)"
  .. ..- attr(*, "order")= int [1:2] 1 1
  .. ..- attr(*, "intercept")= int 1
  .. ..- attr(*, "response")= int 1
  .. ..- attr(*, ".Environment")=<environment: R_GlobalEnv> 
  .. ..- attr(*, "predvars")= language list(log(Volume), log(Height), log(Girth))
  .. ..- attr(*, "dataClasses")= Named chr [1:3] "numeric" "numeric" "numeric"
  .. .. ..- attr(*, "names")= chr [1:3] "log(Volume)" "log(Height)" "log(Girth)"
> mat <- model.matrix(ff, m)
> 
> dd <- data.frame(a = gl(3,4), b = gl(4,1,12)) # balanced 2-way
> options("contrasts") # typically 'treatment' (for unordered factors)
$contrasts
        unordered           ordered 
"contr.treatment"      "contr.poly" 

> model.matrix(~ a + b, dd)
   (Intercept) a2 a3 b2 b3 b4
1            1  0  0  0  0  0
2            1  0  0  1  0  0
3            1  0  0  0  1  0
4            1  0  0  0  0  1
5            1  1  0  0  0  0
6            1  1  0  1  0  0
7            1  1  0  0  1  0
8            1  1  0  0  0  1
9            1  0  1  0  0  0
10           1  0  1  1  0  0
11           1  0  1  0  1  0
12           1  0  1  0  0  1
attr(,"assign")
[1] 0 1 1 2 2 2
attr(,"contrasts")
attr(,"contrasts")$a
[1] "contr.treatment"

attr(,"contrasts")$b
[1] "contr.treatment"

> model.matrix(~ a + b, dd, contrasts.arg = list(a = "contr.sum"))
   (Intercept) a1 a2 b2 b3 b4
1            1  1  0  0  0  0
2            1  1  0  1  0  0
3            1  1  0  0  1  0
4            1  1  0  0  0  1
5            1  0  1  0  0  0
6            1  0  1  1  0  0
7            1  0  1  0  1  0
8            1  0  1  0  0  1
9            1 -1 -1  0  0  0
10           1 -1 -1  1  0  0
11           1 -1 -1  0  1  0
12           1 -1 -1  0  0  1
attr(,"assign")
[1] 0 1 1 2 2 2
attr(,"contrasts")
attr(,"contrasts")$a
[1] "contr.sum"

attr(,"contrasts")$b
[1] "contr.treatment"

> model.matrix(~ a + b, dd, contrasts.arg = list(a = "contr.sum", b = contr.poly))
   (Intercept) a1 a2        b.L  b.Q        b.C
1            1  1  0 -0.6708204  0.5 -0.2236068
2            1  1  0 -0.2236068 -0.5  0.6708204
3            1  1  0  0.2236068 -0.5 -0.6708204
4            1  1  0  0.6708204  0.5  0.2236068
5            1  0  1 -0.6708204  0.5 -0.2236068
6            1  0  1 -0.2236068 -0.5  0.6708204
7            1  0  1  0.2236068 -0.5 -0.6708204
8            1  0  1  0.6708204  0.5  0.2236068
9            1 -1 -1 -0.6708204  0.5 -0.2236068
10           1 -1 -1 -0.2236068 -0.5  0.6708204
11           1 -1 -1  0.2236068 -0.5 -0.6708204
12           1 -1 -1  0.6708204  0.5  0.2236068
attr(,"assign")
[1] 0 1 1 2 2 2
attr(,"contrasts")
attr(,"contrasts")$a
[1] "contr.sum"

attr(,"contrasts")$b
          .L   .Q         .C
1 -0.6708204  0.5 -0.2236068
2 -0.2236068 -0.5  0.6708204
3  0.2236068 -0.5 -0.6708204
4  0.6708204  0.5  0.2236068

> m.orth <- model.matrix(~a+b, dd, contrasts.arg = list(a = "contr.helmert"))
> crossprod(m.orth) # m.orth is  ALMOST  orthogonal
            (Intercept) a1 a2 b2 b3 b4
(Intercept)          12  0  0  3  3  3
a1                    0  8  0  0  0  0
a2                    0  0 24  0  0  0
b2                    3  0  0  3  0  0
b3                    3  0  0  0  3  0
b4                    3  0  0  0  0  3
> # invalid contrasts.. ignored with a warning:
> stopifnot(identical(
+    model.matrix(~ a + b, dd),
+    model.matrix(~ a + b, dd, contrasts.arg = "contr.FOO")))
Warning in model.matrix.default(~a + b, dd, contrasts.arg = "contr.FOO") :
  non-list contrasts argument ignored
> 
> 
> 
> cleanEx()
> nameEx("model.tables")
> ### * model.tables
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: model.tables
> ### Title: Compute Tables of Results from an Aov Model Fit
> ### Aliases: model.tables model.tables.aov model.tables.aovlist
> ### Keywords: models
> 
> ### ** Examples
> 
> 
> cleanEx()
> nameEx("monthplot")
> ### * monthplot
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: monthplot
> ### Title: Plot a Seasonal or other Subseries from a Time Series
> ### Aliases: monthplot monthplot.default monthplot.ts monthplot.stl
> ###   monthplot.StructTS
> ### Keywords: hplot ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## The CO2 data
> fit <- stl(log(co2), s.window = 20, t.window = 20)
> plot(fit)
> op <- par(mfrow = c(2,2))
> monthplot(co2, ylab = "data", cex.axis = 0.8)
> monthplot(fit, choice = "seasonal", cex.axis = 0.8)
> monthplot(fit, choice = "trend", cex.axis = 0.8)
> monthplot(fit, choice = "remainder", type = "h", cex.axis = 0.8)
> par(op)
> 
> ## The CO2 data, grouped quarterly
> quarter <- (cycle(co2) - 1) %/% 3
> monthplot(co2, phase = quarter)
> 
> ## see also JohnsonJohnson
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("mood.test")
> ### * mood.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: mood.test
> ### Title: Mood Two-Sample Test of Scale
> ### Aliases: mood.test mood.test.default mood.test.formula
> ### Keywords: htest
> 
> ### ** Examples
> 
> ## Same data as for the Ansari-Bradley test:
> ## Serum iron determination using Hyland control sera
> ramsay <- c(111, 107, 100, 99, 102, 106, 109, 108, 104, 99,
+             101, 96, 97, 102, 107, 113, 116, 113, 110, 98)
> jung.parekh <- c(107, 108, 106, 98, 105, 103, 110, 105, 104,
+             100, 96, 108, 103, 104, 114, 114, 113, 108, 106, 99)
> mood.test(ramsay, jung.parekh)

	Mood two-sample test of scale

data:  ramsay and jung.parekh
Z = 1.0371, p-value = 0.2997
alternative hypothesis: two.sided

> ## Compare this to ansari.test(ramsay, jung.parekh)
> 
> 
> 
> cleanEx()
> nameEx("na.action")
> ### * na.action
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: na.action
> ### Title: NA Action
> ### Aliases: na.action na.action.default
> ### Keywords: NA methods
> 
> ### ** Examples
> 
> na.action(na.omit(c(1, NA)))
[1] 2
attr(,"class")
[1] "omit"
> 
> 
> 
> cleanEx()
> nameEx("na.contiguous")
> ### * na.contiguous
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: na.contiguous
> ### Title: Find Longest Contiguous Stretch of non-NAs
> ### Aliases: na.contiguous na.contiguous.default
> ### Keywords: ts
> 
> ### ** Examples
> 
> na.contiguous(presidents)
     Qtr1 Qtr2 Qtr3 Qtr4
1952                  32
1953   59   74   75   60
1954   71   61   71   57
1955   71   68   79   73
1956   76   71   67   75
1957   79   62   63   57
1958   60   49   48   52
1959   57   62   61   66
1960   71   62   61   57
1961   72   83   71   78
1962   79   71   62   74
1963   76   64   62   57
1964   80   73   69   69
1965   71   64   69   62
1966   63   46   56   44
1967   44   52   38   46
1968   36   49   35   44
1969   59   65   65   56
1970   66   53   61   52
1971   51   48   54   49
1972   49   61          
> 
> 
> 
> cleanEx()
> nameEx("na.fail")
> ### * na.fail
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: na.fail
> ### Title: Handle Missing Values in Objects
> ### Aliases: na.fail na.fail.default na.omit na.omit.data.frame
> ###   na.omit.default na.exclude na.exclude.data.frame na.exclude.default
> ###   na.pass
> ### Keywords: NA
> 
> ### ** Examples
> 
> DF <- data.frame(x = c(1, 2, 3), y = c(0, 10, NA))
> na.omit(DF)
  x  y
1 1  0
2 2 10
> m <- as.matrix(DF)
> na.omit(m)
     x  y
[1,] 1  0
[2,] 2 10
attr(,"na.action")
[1] 3
attr(,"class")
[1] "omit"
> stopifnot(all(na.omit(1:3) == 1:3))  # does not affect objects with no NA's
> try(na.fail(DF))   #> Error: missing values in ...
Error in na.fail.default(DF) : missing values in object
> 
> options("na.action")
$na.action
[1] "na.omit"

> 
> 
> 
> cleanEx()
> nameEx("nextn")
> ### * nextn
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: nextn
> ### Title: Find Highly Composite Numbers
> ### Aliases: nextn
> ### Keywords: math
> 
> ### ** Examples
> 
> nextn(1001) # 1024
[1] 1024
> table(nextn(599:630))

600 625 640 
  2  25   5 
> n <- 1:100 ; plot(n, nextn(n) - n, type = "o", lwd=2, cex=1/2)
> 
> 
> 
> cleanEx()
> nameEx("nlm")
> ### * nlm
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: nlm
> ### Title: Non-Linear Minimization
> ### Aliases: nlm
> ### Keywords: nonlinear optimize
> 
> ### ** Examples
> 
> f <- function(x) sum((x-1:length(x))^2)
> nlm(f, c(10,10))
$minimum
[1] 4.303458e-26

$estimate
[1] 1 2

$gradient
[1]  2.757794e-13 -3.099743e-13

$code
[1] 1

$iterations
[1] 2

> nlm(f, c(10,10), print.level = 2)
iteration = 0
Step:
[1] 0 0
Parameter:
[1] 10 10
Function Value
[1] 145
Gradient:
[1] 18.00001 16.00001

iteration = 1
Step:
[1] -9 -8
Parameter:
[1] 1 2
Function Value
[1] 1.721748e-13
Gradient:
[1] 1.551336e-06 1.379735e-06

iteration = 2
Parameter:
[1] 1 2
Function Value
[1] 4.303458e-26
Gradient:
[1]  2.757794e-13 -3.099743e-13

Relative gradient close to zero.
Current iterate is probably solution.

$minimum
[1] 4.303458e-26

$estimate
[1] 1 2

$gradient
[1]  2.757794e-13 -3.099743e-13

$code
[1] 1

$iterations
[1] 2

> utils::str(nlm(f, c(5), hessian = TRUE))
List of 6
 $ minimum   : num 2.44e-24
 $ estimate  : num 1
 $ gradient  : num 1e-06
 $ hessian   : num [1, 1] 2
 $ code      : int 1
 $ iterations: int 1
> 
> f <- function(x, a) sum((x-a)^2)
> nlm(f, c(10,10), a = c(3,5))
$minimum
[1] 3.371781e-25

$estimate
[1] 3 5

$gradient
[1]  6.750156e-13 -9.450218e-13

$code
[1] 1

$iterations
[1] 2

> f <- function(x, a)
+ {
+     res <- sum((x-a)^2)
+     attr(res, "gradient") <- 2*(x-a)
+     res
+ }
> nlm(f, c(10,10), a = c(3,5))
$minimum
[1] 0

$estimate
[1] 3 5

$gradient
[1] 0 0

$code
[1] 1

$iterations
[1] 1

> 
> ## more examples, including the use of derivatives.
> ## Not run: demo(nlm)
> 
> 
> 
> cleanEx()
> nameEx("nlminb")
> ### * nlminb
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: nlminb
> ### Title: Optimization using PORT routines
> ### Aliases: nlminb
> ### Keywords: optimize
> 
> ### ** Examples
> 
> 
> cleanEx()
> nameEx("nls")
> ### * nls
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: nls
> ### Title: Nonlinear Least Squares
> ### Aliases: nls
> ### Keywords: nonlinear regression models
> 
> ### ** Examples
> 
> ## Don't show: 
> od <- options(digits=5)
> ## End(Don't show)
> require(graphics)
> 
> DNase1 <- subset(DNase, Run == 1)
> 
> ## using a selfStart model
> fm1DNase1 <- nls(density ~ SSlogis(log(conc), Asym, xmid, scal), DNase1)
> summary(fm1DNase1)

Formula: density ~ SSlogis(log(conc), Asym, xmid, scal)

Parameters:
     Estimate Std. Error t value Pr(>|t|)    
Asym   2.3452     0.0782    30.0  2.2e-13 ***
xmid   1.4831     0.0814    18.2  1.2e-10 ***
scal   1.0415     0.0323    32.3  8.5e-14 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 0.0192 on 13 degrees of freedom

> ## the coefficients only:
> coef(fm1DNase1)
  Asym   xmid   scal 
2.3452 1.4831 1.0415 
> ## including their SE, etc:
> coef(summary(fm1DNase1))
     Estimate Std. Error t value   Pr(>|t|)
Asym   2.3452   0.078154  30.007 2.1655e-13
xmid   1.4831   0.081353  18.230 1.2185e-10
scal   1.0415   0.032271  32.272 8.5069e-14
> 
> ## using conditional linearity
> fm2DNase1 <- nls(density ~ 1/(1 + exp((xmid - log(conc))/scal)),
+                  data = DNase1,
+                  start = list(xmid = 0, scal = 1),
+                  algorithm = "plinear")
> summary(fm2DNase1)

Formula: density ~ 1/(1 + exp((xmid - log(conc))/scal))

Parameters:
     Estimate Std. Error t value Pr(>|t|)    
xmid   1.4831     0.0814    18.2  1.2e-10 ***
scal   1.0415     0.0323    32.3  8.5e-14 ***
.lin   2.3452     0.0782    30.0  2.2e-13 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 0.0192 on 13 degrees of freedom

> 
> ## without conditional linearity
> fm3DNase1 <- nls(density ~ Asym/(1 + exp((xmid - log(conc))/scal)),
+                  data = DNase1,
+                  start = list(Asym = 3, xmid = 0, scal = 1))
> summary(fm3DNase1)

Formula: density ~ Asym/(1 + exp((xmid - log(conc))/scal))

Parameters:
     Estimate Std. Error t value Pr(>|t|)    
Asym   2.3452     0.0782    30.0  2.2e-13 ***
xmid   1.4831     0.0814    18.2  1.2e-10 ***
scal   1.0415     0.0323    32.3  8.5e-14 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 0.0192 on 13 degrees of freedom

> 
> ## using Port's nl2sol algorithm
> fm4DNase1 <- nls(density ~ Asym/(1 + exp((xmid - log(conc))/scal)),
+                  data = DNase1,
+                  start = list(Asym = 3, xmid = 0, scal = 1),
+                  algorithm = "port")
> summary(fm4DNase1)

Formula: density ~ Asym/(1 + exp((xmid - log(conc))/scal))

Parameters:
     Estimate Std. Error t value Pr(>|t|)    
Asym   2.3452     0.0782    30.0  2.2e-13 ***
xmid   1.4831     0.0814    18.2  1.2e-10 ***
scal   1.0415     0.0323    32.3  8.5e-14 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 0.0192 on 13 degrees of freedom

Algorithm "port", convergence message: relative convergence (4)

> 
> ## weighted nonlinear regression
> Treated <- Puromycin[Puromycin$state == "treated", ]
> weighted.MM <- function(resp, conc, Vm, K)
+ {
+     ## Purpose: exactly as white book p. 451 -- RHS for nls()
+     ##  Weighted version of Michaelis-Menten model
+     ## ----------------------------------------------------------
+     ## Arguments: 'y', 'x' and the two parameters (see book)
+     ## ----------------------------------------------------------
+     ## Author: Martin Maechler, Date: 23 Mar 2001
+ 
+     pred <- (Vm * conc)/(K + conc)
+     (resp - pred) / sqrt(pred)
+ }
> 
> Pur.wt <- nls( ~ weighted.MM(rate, conc, Vm, K), data = Treated,
+               start = list(Vm = 200, K = 0.1))
> summary(Pur.wt)

Formula: 0 ~ weighted.MM(rate, conc, Vm, K)

Parameters:
   Estimate Std. Error t value Pr(>|t|)    
Vm 2.07e+02   9.22e+00   22.42  7.0e-10 ***
K  5.46e-02   7.98e-03    6.84  4.5e-05 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 1.21 on 10 degrees of freedom

> 
> ## Passing arguments using a list that can not be coerced to a data.frame
> lisTreat <- with(Treated,
+                  list(conc1 = conc[1], conc.1 = conc[-1], rate = rate))
> 
> weighted.MM1 <- function(resp, conc1, conc.1, Vm, K)
+ {
+      conc <- c(conc1, conc.1)
+      pred <- (Vm * conc)/(K + conc)
+     (resp - pred) / sqrt(pred)
+ }
> Pur.wt1 <- nls( ~ weighted.MM1(rate, conc1, conc.1, Vm, K),
+                data = lisTreat, start = list(Vm = 200, K = 0.1))
> stopifnot(all.equal(coef(Pur.wt), coef(Pur.wt1)))
> 
> ## Chambers and Hastie (1992) Statistical Models in S  (p. 537):
> ## If the value of the right side [of formula] has an attribute called
> ## 'gradient' this should be a matrix with the number of rows equal
> ## to the length of the response and one column for each parameter.
> 
> weighted.MM.grad <- function(resp, conc1, conc.1, Vm, K)
+ {
+   conc <- c(conc1, conc.1)
+ 
+   K.conc <- K+conc
+   dy.dV <- conc/K.conc
+   dy.dK <- -Vm*dy.dV/K.conc
+   pred <- Vm*dy.dV
+   pred.5 <- sqrt(pred)
+   dev <- (resp - pred) / pred.5
+   Ddev <- -0.5*(resp+pred)/(pred.5*pred)
+   attr(dev, "gradient") <- Ddev * cbind(Vm = dy.dV, K = dy.dK)
+   dev
+ }
> 
> Pur.wt.grad <- nls( ~ weighted.MM.grad(rate, conc1, conc.1, Vm, K),
+                    data = lisTreat, start = list(Vm = 200, K = 0.1))
> 
> rbind(coef(Pur.wt), coef(Pur.wt1), coef(Pur.wt.grad))
         Vm        K
[1,] 206.83 0.054611
[2,] 206.83 0.054611
[3,] 206.83 0.054611
> 
> ## In this example, there seems no advantage to providing the gradient.
> ## In other cases, there might be.
> 
> 
> ## The two examples below show that you can fit a model to
> ## artificial data with noise but not to artificial data
> ## without noise.
> x <- 1:10
> y <- 2*x + 3                            # perfect fit
> ## terminates in an error, because convergence cannot be confirmed:
> try(nls(y ~ a + b*x, start = list(a = 0.12345, b = 0.54321)))
Error in nls(y ~ a + b * x, start = list(a = 0.12345, b = 0.54321)) : 
  number of iterations exceeded maximum of 50
> ## adjusting the convergence test by adding 'scaleOffset' to its denominator RSS:
> nls(y ~ a + b*x, start = list(a = 0.12345, b = 0.54321),
+     control = list(scaleOffset = 1, printEval=TRUE))
  It.   1, fac=           1, eval (no.,total): ( 1,  1): new dev = 1.05935e-12
Nonlinear regression model
  model: y ~ a + b * x
   data: parent.frame()
a b 
3 2 
 residual sum-of-squares: 1.06e-12
> ## Alternatively jittering the "too exact" values, slightly:
> set.seed(27)
> yeps <- y + rnorm(length(y), sd = 0.01) # added noise
> nls(yeps ~ a + b*x, start = list(a = 0.12345, b = 0.54321))
Nonlinear regression model
  model: yeps ~ a + b * x
   data: parent.frame()
a b 
3 2 
 residual sum-of-squares: 0.00135
> 
> 
> ## the nls() internal cheap guess for starting values can be sufficient:
> x <- -(1:100)/10
> y <- 100 + 10 * exp(x / 2) + rnorm(x)/10
> nlmod <- nls(y ~  Const + A * exp(B * x))
Warning in nls(y ~ Const + A * exp(B * x)) :
  No starting values specified for some parameters.
Initializing ‘Const’, ‘A’, ‘B’ to '1.'.
Consider specifying 'start' or using a selfStart model
> 
> plot(x,y, main = "nls(*), data, true function and fit, n=100")
> curve(100 + 10 * exp(x / 2), col = 4, add = TRUE)
> lines(x, predict(nlmod), col = 2)
> 
> ## Here, requiring close convergence, must use more accurate numerical differentiation,
> ## as this typically gives Error: "step factor .. reduced below 'minFactor' .."
> ## IGNORE_RDIFF_BEGIN
> try(nlm1 <- update(nlmod, control = list(tol = 1e-7)))
Warning in nls(formula = y ~ Const + A * exp(B * x), algorithm = "default",  :
  No starting values specified for some parameters.
Initializing ‘Const’, ‘A’, ‘B’ to '1.'.
Consider specifying 'start' or using a selfStart model
> o2 <- options(digits = 10) # more accuracy for 'trace'
> ## central differencing works here typically (PR#18165: not converging on *some*):
> ctr2 <- nls.control(nDcentral=TRUE, tol = 8e-8, # <- even smaller than above
+    warnOnly =
+         TRUE || # << work around; e.g. needed on some ATLAS-Lapack setups
+         (grepl("^aarch64.*linux", R.version$platform) && grepl("^NixOS", osVersion)
+               ))
> (nlm2 <- update(nlmod, control = ctr2, trace = TRUE)); options(o2)
Warning in nls(formula = y ~ Const + A * exp(B * x), algorithm = "default",  :
  No starting values specified for some parameters.
Initializing ‘Const’, ‘A’, ‘B’ to '1.'.
Consider specifying 'start' or using a selfStart model
1017460.306    (4.15e+02): par = (1 1 1)
758164.7503    (2.34e+02): par = (13.42031396 1.961485 0.05947543746)
269506.3540    (3.23e+02): par = (51.75719814 -13.09155954 0.8428607699)
68969.21900    (1.03e+02): par = (76.00069849 -1.93522673 1.019085799)
633.3672239    (1.29e+00): par = (100.3761515 8.62464841 5.104490279)
151.4400266    (9.39e+00): par = (100.6344391 4.913490966 0.284920948)
53.08740235    (7.24e+00): par = (100.6830408 6.899303242 0.4637755057)
1.344478691    (5.97e-01): par = (100.0368306 9.89771414 0.5169294949)
0.9908415909   (1.55e-02): par = (100.0300625 9.9144191 0.5023516842)
0.9906046057   (1.84e-05): par = (100.0288724 9.916224018 0.5025207337)
0.9906046054   (9.94e-08): par = (100.028875 9.916228366 0.50252165)
0.9906046054   (5.06e-10): par = (100.028875 9.916228388 0.5025216549)
Nonlinear regression model
  model: y ~ Const + A * exp(B * x)
   data: parent.frame()
      Const           A           B 
100.0288750   9.9162284   0.5025217 
 residual sum-of-squares: 0.9906046
> ## --> convergence tolerance  4.997e-8 (in 11 iter.)
> ## IGNORE_RDIFF_END
> 
> ## The muscle dataset in MASS is from an experiment on muscle
> ## contraction on 21 animals.  The observed variables are Strip
> ## (identifier of muscle), Conc (Cacl concentration) and Length
> ## (resulting length of muscle section).
> ## IGNORE_RDIFF_BEGIN
> if(requireNamespace("MASS", quietly = TRUE)) withAutoprint({
+ ## The non linear model considered is
+ ##       Length = alpha + beta*exp(-Conc/theta) + error
+ ## where theta is constant but alpha and beta may vary with Strip.
+ 
+ with(MASS::muscle, table(Strip)) # 2, 3 or 4 obs per strip
+ 
+ ## We first use the plinear algorithm to fit an overall model,
+ ## ignoring that alpha and beta might vary with Strip.
+ musc.1 <- nls(Length ~ cbind(1, exp(-Conc/th)), MASS::muscle,
+               start = list(th = 1), algorithm = "plinear")
+ summary(musc.1)
+ 
+ ## Then we use nls' indexing feature for parameters in non-linear
+ ## models to use the conventional algorithm to fit a model in which
+ ## alpha and beta vary with Strip.  The starting values are provided
+ ## by the previously fitted model.
+ ## Note that with indexed parameters, the starting values must be
+ ## given in a list (with names):
+ b <- coef(musc.1)
+ musc.2 <- nls(Length ~ a[Strip] + b[Strip]*exp(-Conc/th), MASS::muscle,
+               start = list(a = rep(b[2], 21), b = rep(b[3], 21), th = b[1]))
+ summary(musc.2)
+ })
> with(MASS::muscle, table(Strip))
Strip
S01 S02 S03 S04 S05 S06 S07 S08 S09 S10 S11 S12 S13 S14 S15 S16 S17 S18 S19 S20 
  4   4   4   3   3   3   2   2   2   2   3   2   2   2   2   4   4   3   3   3 
S21 
  3 
> musc.1 <- nls(Length ~ cbind(1, exp(-Conc/th)), MASS::muscle, start = list(th = 1), 
+     algorithm = "plinear")
> summary(musc.1)

Formula: Length ~ cbind(1, exp(-Conc/th))

Parameters:
      Estimate Std. Error t value Pr(>|t|)    
th       0.608      0.115    5.31  1.9e-06 ***
.lin1   28.963      1.230   23.55  < 2e-16 ***
.lin2  -34.227      3.793   -9.02  1.4e-12 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 4.67 on 57 degrees of freedom

> b <- coef(musc.1)
> musc.2 <- nls(Length ~ a[Strip] + b[Strip] * exp(-Conc/th), MASS::muscle, 
+     start = list(a = rep(b[2], 21), b = rep(b[3], 21), th = b[1]))
> summary(musc.2)

Formula: Length ~ a[Strip] + b[Strip] * exp(-Conc/th)

Parameters:
    Estimate Std. Error t value Pr(>|t|)    
a1    23.454      0.796   29.46  5.0e-16 ***
a2    28.302      0.793   35.70  < 2e-16 ***
a3    30.801      1.716   17.95  1.7e-12 ***
a4    25.921      3.016    8.60  1.4e-07 ***
a5    23.201      2.891    8.02  3.5e-07 ***
a6    20.120      2.435    8.26  2.3e-07 ***
a7    33.595      1.682   19.98  3.0e-13 ***
a8    39.053      3.753   10.41  8.6e-09 ***
a9    32.137      3.318    9.69  2.5e-08 ***
a10   40.005      3.336   11.99  1.0e-09 ***
a11   36.190      3.109   11.64  1.6e-09 ***
a12   36.911      1.839   20.07  2.8e-13 ***
a13   30.635      1.700   18.02  1.6e-12 ***
a14   34.312      3.495    9.82  2.0e-08 ***
a15   38.395      3.375   11.38  2.3e-09 ***
a16   31.226      0.886   35.26  < 2e-16 ***
a17   31.230      0.821   38.02  < 2e-16 ***
a18   19.998      1.011   19.78  3.6e-13 ***
a19   37.095      1.071   34.65  < 2e-16 ***
a20   32.594      1.121   29.07  6.2e-16 ***
a21   30.376      1.057   28.74  7.5e-16 ***
b1   -27.300      6.873   -3.97  0.00099 ***
b2   -26.270      6.754   -3.89  0.00118 ** 
b3   -30.901      2.270  -13.61  1.4e-10 ***
b4   -32.238      3.810   -8.46  1.7e-07 ***
b5   -29.941      3.773   -7.94  4.1e-07 ***
b6   -20.622      3.647   -5.65  2.9e-05 ***
b7   -19.625      8.085   -2.43  0.02661 *  
b8   -45.780      4.113  -11.13  3.2e-09 ***
b9   -31.345      6.352   -4.93  0.00013 ***
b10  -38.599      3.955   -9.76  2.2e-08 ***
b11  -33.921      3.839   -8.84  9.2e-08 ***
b12  -38.268      8.992   -4.26  0.00053 ***
b13  -22.568      8.194   -2.75  0.01355 *  
b14  -36.167      6.358   -5.69  2.7e-05 ***
b15  -32.952      6.354   -5.19  7.4e-05 ***
b16  -47.207      9.540   -4.95  0.00012 ***
b17  -33.875      7.688   -4.41  0.00039 ***
b18  -15.896      6.222   -2.55  0.02051 *  
b19  -28.969      7.235   -4.00  0.00092 ***
b20  -36.917      8.033   -4.60  0.00026 ***
b21  -26.508      7.012   -3.78  0.00149 ** 
th     0.797      0.127    6.30  8.0e-06 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 1.11 on 17 degrees of freedom

> ## IGNORE_RDIFF_END
> ## Don't show: 
> options(od)
> ## End(Don't show)
> 
> 
> 
> cleanEx()
> nameEx("nls.control")
> ### * nls.control
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: nls.control
> ### Title: Control the Iterations in nls
> ### Aliases: nls.control
> ### Keywords: nonlinear regression models
> 
> ### ** Examples
> 
> nls.control(minFactor = 1/2048)
$maxiter
[1] 50

$tol
[1] 1e-05

$minFactor
[1] 0.0004882812

$printEval
[1] FALSE

$warnOnly
[1] FALSE

$scaleOffset
[1] 0

$nDcentral
[1] FALSE

> 
> 
> 
> cleanEx()
> nameEx("numericDeriv")
> ### * numericDeriv
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: numericDeriv
> ### Title: Evaluate Derivatives Numerically
> ### Aliases: numericDeriv
> ### Keywords: models
> 
> ### ** Examples
> 
> myenv <- new.env()
> myenv$mean <- 0.
> myenv$sd   <- 1.
> myenv$x    <- seq(-3., 3., length.out = 31)
> nD <- numericDeriv(quote(pnorm(x, mean, sd)), c("mean", "sd"), myenv)
> str(nD)
 num [1:31] 0.00135 0.00256 0.00466 0.0082 0.0139 ...
 - attr(*, "gradient")= num [1:31, 1:2] -0.00443 -0.00792 -0.01358 -0.02239 -0.03547 ...
> 
> ## Visualize :
> require(graphics)
> matplot(myenv$x, cbind(c(nD), attr(nD, "gradient")), type="l")
> abline(h=0, lty=3)
> ## "gradient" is close to the true derivatives, you don't see any diff.:
> curve( - dnorm(x), col=2, lty=3, lwd=2, add=TRUE)
> curve(-x*dnorm(x), col=3, lty=3, lwd=2, add=TRUE)
> ##
> ## IGNORE_RDIFF_BEGIN
> # shows 1.609e-8 on most platforms
> all.equal(attr(nD,"gradient"),
+           with(myenv, cbind(-dnorm(x), -x*dnorm(x))))
[1] "Mean relative difference: 1.609569e-08"
> ## IGNORE_RDIFF_END
> 
> 
> 
> cleanEx()
> nameEx("oneway.test")
> ### * oneway.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: oneway.test
> ### Title: Test for Equal Means in a One-Way Layout
> ### Aliases: oneway.test
> ### Keywords: htest
> 
> ### ** Examples
> 
> ## Not assuming equal variances
> oneway.test(extra ~ group, data = sleep)

	One-way analysis of means (not assuming equal variances)

data:  extra and group
F = 3.4626, num df = 1.000, denom df = 17.776, p-value = 0.07939

> ## Assuming equal variances
> oneway.test(extra ~ group, data = sleep, var.equal = TRUE)

	One-way analysis of means

data:  extra and group
F = 3.4626, num df = 1, denom df = 18, p-value = 0.07919

> ## which gives the same result as
> anova(lm(extra ~ group, data = sleep))
Analysis of Variance Table

Response: extra
          Df Sum Sq Mean Sq F value  Pr(>F)  
group      1 12.482 12.4820  3.4626 0.07919 .
Residuals 18 64.886  3.6048                  
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
> 
> 
> 
> cleanEx()
> nameEx("optim")
> ### * optim
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: optim
> ### Title: General-purpose Optimization
> ### Aliases: optim optimHess
> ### Keywords: nonlinear optimize
> 
> ### ** Examples
> 
> 
> cleanEx()
> nameEx("optimize")
> ### * optimize
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: optimize
> ### Title: One Dimensional Optimization
> ### Aliases: optimize optimise
> ### Keywords: optimize
> 
> ### ** Examples
> 
> require(graphics)
> 
> f <- function (x, a) (x - a)^2
> xmin <- optimize(f, c(0, 1), tol = 0.0001, a = 1/3)
> xmin
$minimum
[1] 0.3333333

$objective
[1] 0

> 
> ## See where the function is evaluated:
> optimize(function(x) x^2*(print(x)-1), lower = 0, upper = 10)
[1] 3.81966
[1] 6.18034
[1] 2.36068
[1] 2.077939
[1] 1.505823
[1] 0.9306496
[1] 0.9196752
[1] 0.772905
[1] 0.4776816
[1] 0.6491436
[1] 0.656315
[1] 0.6653777
[1] 0.6667786
[1] 0.6666728
[1] 0.6666321
[1] 0.6667135
[1] 0.6666728
$minimum
[1] 0.6666728

$objective
[1] -0.1481481

> 
> ## "wrong" solution with unlucky interval and piecewise constant f():
> f  <- function(x) ifelse(x > -1, ifelse(x < 4, exp(-1/abs(x - 1)), 10), 10)
> fp <- function(x) { print(x); f(x) }
> 
> plot(f, -2,5, ylim = 0:1, col = 2)
> optimize(fp, c(-4, 20))   # doesn't see the minimum
[1] 5.167184
[1] 10.83282
[1] 14.33437
[1] 16.49845
[1] 17.83592
[1] 18.66253
[1] 19.1734
[1] 19.48913
[1] 19.68427
[1] 19.80487
[1] 19.8794
[1] 19.92547
[1] 19.95393
[1] 19.97153
[1] 19.9824
[1] 19.98913
[1] 19.99328
[1] 19.99585
[1] 19.99743
[1] 19.99841
[1] 19.99902
[1] 19.99939
[1] 19.99963
[1] 19.99977
[1] 19.99986
[1] 19.99991
[1] 19.99995
[1] 19.99995
$minimum
[1] 19.99995

$objective
[1] 10

> optimize(fp, c(-7, 20))   # ok
[1] 3.313082
[1] 9.686918
[1] -0.6261646
[1] 1.244956
[1] 1.250965
[1] 0.771827
[1] 0.2378417
[1] 1.000451
[1] 0.9906964
[1] 0.9955736
[1] 0.9980122
[1] 0.9992315
[1] 0.9998411
[1] 0.9996083
[1] 0.9994644
[1] 0.9993754
[1] 0.9993204
[1] 0.9992797
[1] 0.9992797
$minimum
[1] 0.9992797

$objective
[1] 0

> 
> 
> 
> cleanEx()
> nameEx("order.dendrogram")
> ### * order.dendrogram
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: order.dendrogram
> ### Title: Ordering or Labels of the Leaves in a Dendrogram
> ### Aliases: order.dendrogram labels.dendrogram
> ### Keywords: manip
> 
> ### ** Examples
> 
> set.seed(123)
> x <- rnorm(10)
> hc <- hclust(dist(x))
> hc$order
 [1]  3  6  7  2  4  5  8  9  1 10
> dd <- as.dendrogram(hc)
> order.dendrogram(dd) ## the same :
 [1]  3  6  7  2  4  5  8  9  1 10
> stopifnot(hc$order == order.dendrogram(dd))
> 
> d2 <- as.dendrogram(hclust(dist(USArrests)))
> labels(d2) ## in this case the same as
 [1] "Florida"        "North Carolina" "Delaware"       "Alabama"       
 [5] "Louisiana"      "Alaska"         "Mississippi"    "South Carolina"
 [9] "Maryland"       "Arizona"        "New Mexico"     "California"    
[13] "Illinois"       "New York"       "Michigan"       "Nevada"        
[17] "Missouri"       "Arkansas"       "Tennessee"      "Georgia"       
[21] "Colorado"       "Texas"          "Rhode Island"   "Wyoming"       
[25] "Oregon"         "Oklahoma"       "Virginia"       "Washington"    
[29] "Massachusetts"  "New Jersey"     "Ohio"           "Utah"          
[33] "Connecticut"    "Pennsylvania"   "Nebraska"       "Kentucky"      
[37] "Montana"        "Idaho"          "Indiana"        "Kansas"        
[41] "Hawaii"         "Minnesota"      "Wisconsin"      "Iowa"          
[45] "New Hampshire"  "West Virginia"  "Maine"          "South Dakota"  
[49] "North Dakota"   "Vermont"       
> stopifnot(identical(labels(d2),
+    rownames(USArrests)[order.dendrogram(d2)]))
> 
> 
> 
> cleanEx()
> nameEx("p.adjust")
> ### * p.adjust
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: p.adjust
> ### Title: Adjust P-values for Multiple Comparisons
> ### Aliases: p.adjust p.adjust.methods
> ### Keywords: htest
> 
> ### ** Examples
> 
> require(graphics)
> 
> set.seed(123)
> x <- rnorm(50, mean = c(rep(0, 25), rep(3, 25)))
> p <- 2*pnorm(sort(-abs(x)))
> 
> round(p, 3)
 [1] 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.001 0.002
[13] 0.003 0.004 0.005 0.007 0.007 0.009 0.009 0.011 0.021 0.049 0.061 0.063
[25] 0.074 0.083 0.086 0.119 0.189 0.206 0.221 0.286 0.305 0.466 0.483 0.492
[37] 0.532 0.575 0.578 0.619 0.636 0.645 0.656 0.689 0.719 0.818 0.827 0.897
[49] 0.912 0.944
> round(p.adjust(p), 3)
 [1] 0.000 0.001 0.001 0.005 0.005 0.006 0.006 0.007 0.009 0.016 0.024 0.063
[13] 0.125 0.131 0.189 0.239 0.240 0.291 0.301 0.350 0.635 1.000 1.000 1.000
[25] 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000
[37] 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000 1.000
[49] 1.000 1.000
> round(p.adjust(p, "BH"), 3)
 [1] 0.000 0.000 0.000 0.001 0.001 0.001 0.001 0.001 0.001 0.002 0.003 0.007
[13] 0.013 0.013 0.017 0.021 0.021 0.024 0.025 0.028 0.050 0.112 0.130 0.130
[25] 0.148 0.159 0.160 0.213 0.326 0.343 0.356 0.446 0.462 0.684 0.684 0.684
[37] 0.719 0.741 0.741 0.763 0.763 0.763 0.763 0.782 0.799 0.880 0.880 0.930
[49] 0.930 0.944
> 
> ## or all of them at once (dropping the "fdr" alias):
> p.adjust.M <- p.adjust.methods[p.adjust.methods != "fdr"]
> p.adj    <- sapply(p.adjust.M, function(meth) p.adjust(p, meth))
> p.adj.60 <- sapply(p.adjust.M, function(meth) p.adjust(p, meth, n = 60))
> stopifnot(identical(p.adj[,"none"], p), p.adj <= p.adj.60)
> round(p.adj, 3)
       holm hochberg hommel bonferroni    BH    BY  none
 [1,] 0.000    0.000  0.000      0.000 0.000 0.000 0.000
 [2,] 0.001    0.001  0.001      0.001 0.000 0.002 0.000
 [3,] 0.001    0.001  0.001      0.001 0.000 0.002 0.000
 [4,] 0.005    0.005  0.004      0.005 0.001 0.004 0.000
 [5,] 0.005    0.005  0.005      0.005 0.001 0.004 0.000
 [6,] 0.006    0.006  0.005      0.006 0.001 0.004 0.000
 [7,] 0.006    0.006  0.006      0.007 0.001 0.004 0.000
 [8,] 0.007    0.007  0.007      0.008 0.001 0.004 0.000
 [9,] 0.009    0.009  0.009      0.011 0.001 0.006 0.000
[10,] 0.016    0.016  0.015      0.019 0.002 0.009 0.000
[11,] 0.024    0.024  0.024      0.031 0.003 0.013 0.001
[12,] 0.063    0.063  0.058      0.081 0.007 0.030 0.002
[13,] 0.125    0.125  0.109      0.165 0.013 0.057 0.003
[14,] 0.131    0.131  0.117      0.177 0.013 0.057 0.004
[15,] 0.189    0.189  0.168      0.262 0.017 0.079 0.005
[16,] 0.239    0.239  0.212      0.342 0.021 0.093 0.007
[17,] 0.240    0.240  0.219      0.353 0.021 0.093 0.007
[18,] 0.291    0.291  0.273      0.440 0.024 0.110 0.009
[19,] 0.301    0.301  0.291      0.470 0.025 0.111 0.009
[20,] 0.350    0.350  0.339      0.565 0.028 0.127 0.011
[21,] 0.635    0.635  0.571      1.000 0.050 0.227 0.021
[22,] 1.000    0.944  0.944      1.000 0.112 0.503 0.049
[23,] 1.000    0.944  0.944      1.000 0.130 0.587 0.061
[24,] 1.000    0.944  0.944      1.000 0.130 0.587 0.063
[25,] 1.000    0.944  0.944      1.000 0.148 0.665 0.074
[26,] 1.000    0.944  0.944      1.000 0.159 0.717 0.083
[27,] 1.000    0.944  0.944      1.000 0.160 0.719 0.086
[28,] 1.000    0.944  0.944      1.000 0.213 0.957 0.119
[29,] 1.000    0.944  0.944      1.000 0.326 1.000 0.189
[30,] 1.000    0.944  0.944      1.000 0.343 1.000 0.206
[31,] 1.000    0.944  0.944      1.000 0.356 1.000 0.221
[32,] 1.000    0.944  0.944      1.000 0.446 1.000 0.286
[33,] 1.000    0.944  0.944      1.000 0.462 1.000 0.305
[34,] 1.000    0.944  0.944      1.000 0.684 1.000 0.466
[35,] 1.000    0.944  0.944      1.000 0.684 1.000 0.483
[36,] 1.000    0.944  0.944      1.000 0.684 1.000 0.492
[37,] 1.000    0.944  0.944      1.000 0.719 1.000 0.532
[38,] 1.000    0.944  0.944      1.000 0.741 1.000 0.575
[39,] 1.000    0.944  0.944      1.000 0.741 1.000 0.578
[40,] 1.000    0.944  0.944      1.000 0.763 1.000 0.619
[41,] 1.000    0.944  0.944      1.000 0.763 1.000 0.636
[42,] 1.000    0.944  0.944      1.000 0.763 1.000 0.645
[43,] 1.000    0.944  0.944      1.000 0.763 1.000 0.656
[44,] 1.000    0.944  0.944      1.000 0.782 1.000 0.689
[45,] 1.000    0.944  0.944      1.000 0.799 1.000 0.719
[46,] 1.000    0.944  0.944      1.000 0.880 1.000 0.818
[47,] 1.000    0.944  0.944      1.000 0.880 1.000 0.827
[48,] 1.000    0.944  0.944      1.000 0.930 1.000 0.897
[49,] 1.000    0.944  0.944      1.000 0.930 1.000 0.912
[50,] 1.000    0.944  0.944      1.000 0.944 1.000 0.944
> ## or a bit nicer:
> noquote(apply(p.adj, 2, format.pval, digits = 3))
      holm     hochberg hommel   bonferroni BH       BY      none    
 [1,] 1.18e-05 1.18e-05 1.18e-05 1.18e-05   1.18e-05 5.3e-05 2.35e-07
 [2,] 0.00103  0.00103  0.00101  0.00105    0.000429 0.00193 2.10e-05
 [3,] 0.00124  0.00124  0.00124  0.00129    0.000429 0.00193 2.58e-05
 [4,] 0.00461  0.00461  0.00422  0.00491    0.000947 0.00426 9.81e-05
 [5,] 0.00484  0.00484  0.00453  0.00526    0.000947 0.00426 0.000105
 [6,] 0.00559  0.00559  0.00521  0.00621    0.000947 0.00426 0.000124
 [7,] 0.00583  0.00583  0.00557  0.00663    0.000947 0.00426 0.000133
 [8,] 0.00674  0.00674  0.00659  0.00784    0.000980 0.00441 0.000157
 [9,] 0.00947  0.00947  0.00924  0.01127    0.001253 0.00564 0.000225
[10,] 0.01556  0.01556  0.01518  0.01898    0.001898 0.00854 0.000380
[11,] 0.02446  0.02446  0.02446  0.03057    0.002780 0.01251 0.000611
[12,] 0.06294  0.06294  0.05810  0.08070    0.006725 0.03026 0.001614
[13,] 0.12549  0.12549  0.10898  0.16512    0.012637 0.05686 0.003302
[14,] 0.13092  0.13092  0.11677  0.17692    0.012637 0.05686 0.003538
[15,] 0.18853  0.18853  0.16758  0.26185    0.017457 0.07854 0.005237
[16,] 0.23912  0.23912  0.21179  0.34160    0.020762 0.09341 0.006832
[17,] 0.24001  0.24001  0.21884  0.35296    0.020762 0.09341 0.007059
[18,] 0.29057  0.29057  0.27296  0.44026    0.024459 0.11004 0.008805
[19,] 0.30083  0.30083  0.29143  0.47005    0.024740 0.11131 0.009401
[20,] 0.35024  0.35024  0.33894  0.56490    0.028245 0.12708 0.011298
[21,] 0.63451  0.63451  0.57105  1.00000    0.050358 0.22657 0.021150
[22,] 1.00000  0.94379  0.94379  1.00000    0.111880 0.50337 0.049227
[23,] 1.00000  0.94379  0.94379  1.00000    0.130463 0.58698 0.060533
[24,] 1.00000  0.94379  0.94379  1.00000    0.130463 0.58698 0.062622
[25,] 1.00000  0.94379  0.94379  1.00000    0.147903 0.66545 0.073952
[26,] 1.00000  0.94379  0.94379  1.00000    0.159252 0.71651 0.082811
[27,] 1.00000  0.94379  0.94379  1.00000    0.159877 0.71932 0.086333
[28,] 1.00000  0.94379  0.94379  1.00000    0.212617 0.95661 0.119065
[29,] 1.00000  0.94379  0.94379  1.00000    0.325999 1.00000 0.189080
[30,] 1.00000  0.94379  0.94379  1.00000    0.343082 1.00000 0.205849
[31,] 1.00000  0.94379  0.94379  1.00000    0.356325 1.00000 0.220921
[32,] 1.00000  0.94379  0.94379  1.00000    0.446250 1.00000 0.285600
[33,] 1.00000  0.94379  0.94379  1.00000    0.461954 1.00000 0.304889
[34,] 1.00000  0.94379  0.94379  1.00000    0.683577 1.00000 0.466068
[35,] 1.00000  0.94379  0.94379  1.00000    0.683577 1.00000 0.483081
[36,] 1.00000  0.94379  0.94379  1.00000    0.683577 1.00000 0.492175
[37,] 1.00000  0.94379  0.94379  1.00000    0.718845 1.00000 0.531945
[38,] 1.00000  0.94379  0.94379  1.00000    0.741435 1.00000 0.575155
[39,] 1.00000  0.94379  0.94379  1.00000    0.741435 1.00000 0.578319
[40,] 1.00000  0.94379  0.94379  1.00000    0.762606 1.00000 0.618589
[41,] 1.00000  0.94379  0.94379  1.00000    0.762606 1.00000 0.636362
[42,] 1.00000  0.94379  0.94379  1.00000    0.762606 1.00000 0.644859
[43,] 1.00000  0.94379  0.94379  1.00000    0.762606 1.00000 0.655841
[44,] 1.00000  0.94379  0.94379  1.00000    0.782487 1.00000 0.688588
[45,] 1.00000  0.94379  0.94379  1.00000    0.798874 1.00000 0.718986
[46,] 1.00000  0.94379  0.94379  1.00000    0.880265 1.00000 0.817954
[47,] 1.00000  0.94379  0.94379  1.00000    0.880265 1.00000 0.827449
[48,] 1.00000  0.94379  0.94379  1.00000    0.930478 1.00000 0.897130
[49,] 1.00000  0.94379  0.94379  1.00000    0.930478 1.00000 0.911868
[50,] 1.00000  0.94379  0.94379  1.00000    0.943789 1.00000 0.943789
> 
> 
> ## and a graphic:
> matplot(p, p.adj, ylab="p.adjust(p, meth)", type = "l", asp = 1, lty = 1:6,
+         main = "P-value adjustments")
> legend(0.7, 0.6, p.adjust.M, col = 1:6, lty = 1:6)
> 
> ## Can work with NA's:
> pN <- p; iN <- c(46, 47); pN[iN] <- NA
> pN.a <- sapply(p.adjust.M, function(meth) p.adjust(pN, meth))
> ## The smallest 20 P-values all affected by the NA's :
> round((pN.a / p.adj)[1:20, ] , 4)
        holm hochberg hommel bonferroni   BH     BY none
 [1,] 0.9600   0.9600 0.9600       0.96 0.96 0.9514    1
 [2,] 0.9592   0.9592 0.9583       0.96 0.96 0.9514    1
 [3,] 0.9583   0.9583 0.9583       0.96 0.96 0.9514    1
 [4,] 0.9574   0.9574 0.9535       0.96 0.96 0.9514    1
 [5,] 0.9565   0.9565 0.9535       0.96 0.96 0.9514    1
 [6,] 0.9556   0.9556 0.9524       0.96 0.96 0.9514    1
 [7,] 0.9545   0.9545 0.9524       0.96 0.96 0.9514    1
 [8,] 0.9535   0.9535 0.9524       0.96 0.96 0.9514    1
 [9,] 0.9524   0.9524 0.9512       0.96 0.96 0.9514    1
[10,] 0.9512   0.9512 0.9500       0.96 0.96 0.9514    1
[11,] 0.9500   0.9500 0.9500       0.96 0.96 0.9514    1
[12,] 0.9487   0.9487 0.9444       0.96 0.96 0.9514    1
[13,] 0.9474   0.9474 0.9394       0.96 0.96 0.9514    1
[14,] 0.9459   0.9459 0.9394       0.96 0.96 0.9514    1
[15,] 0.9444   0.9444 0.9375       0.96 0.96 0.9514    1
[16,] 0.9429   0.9429 0.9355       0.96 0.96 0.9514    1
[17,] 0.9412   0.9412 0.9355       0.96 0.96 0.9514    1
[18,] 0.9394   0.9394 0.9355       0.96 0.96 0.9514    1
[19,] 0.9375   0.9375 0.9355       0.96 0.96 0.9514    1
[20,] 0.9355   0.9355 0.9333       0.96 0.96 0.9514    1
> 
> 
> 
> cleanEx()
> nameEx("pairwise.prop.test")
> ### * pairwise.prop.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: pairwise.prop.test
> ### Title: Pairwise comparisons for proportions
> ### Aliases: pairwise.prop.test
> ### Keywords: htest
> 
> ### ** Examples
> 
> smokers  <- c( 83, 90, 129, 70 )
> patients <- c( 86, 93, 136, 82 )
> pairwise.prop.test(smokers, patients)
Warning in prop.test(x[c(i, j)], n[c(i, j)], ...) :
  Chi-squared approximation may be incorrect
Warning in prop.test(x[c(i, j)], n[c(i, j)], ...) :
  Chi-squared approximation may be incorrect
Warning in prop.test(x[c(i, j)], n[c(i, j)], ...) :
  Chi-squared approximation may be incorrect

	Pairwise comparisons using Pairwise comparison of proportions 

data:  smokers out of patients 

  1     2     3    
2 1.000 -     -    
3 1.000 1.000 -    
4 0.119 0.093 0.124

P value adjustment method: holm 
> 
> 
> 
> cleanEx()
> nameEx("pairwise.t.test")
> ### * pairwise.t.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: pairwise.t.test
> ### Title: Pairwise t tests
> ### Aliases: pairwise.t.test
> ### Keywords: htest
> 
> ### ** Examples
> 
> attach(airquality)
> Month <- factor(Month, labels = month.abb[5:9])
> pairwise.t.test(Ozone, Month)

	Pairwise comparisons using t tests with pooled SD 

data:  Ozone and Month 

    May     Jun     Jul     Aug    
Jun 1.00000 -       -       -      
Jul 0.00026 0.05113 -       -      
Aug 0.00019 0.04987 1.00000 -      
Sep 1.00000 1.00000 0.00488 0.00388

P value adjustment method: holm 
> pairwise.t.test(Ozone, Month, p.adjust.method = "bonf")

	Pairwise comparisons using t tests with pooled SD 

data:  Ozone and Month 

    May     Jun     Jul     Aug    
Jun 1.00000 -       -       -      
Jul 0.00029 0.10225 -       -      
Aug 0.00019 0.08312 1.00000 -      
Sep 1.00000 1.00000 0.00697 0.00485

P value adjustment method: bonferroni 
> pairwise.t.test(Ozone, Month, pool.sd = FALSE)

	Pairwise comparisons using t tests with non-pooled SD 

data:  Ozone and Month 

    May     Jun     Jul     Aug    
Jun 1.00000 -       -       -      
Jul 0.00026 0.01527 -       -      
Aug 0.00195 0.02135 1.00000 -      
Sep 0.86321 1.00000 0.00589 0.01721

P value adjustment method: holm 
> detach()
> 
> 
> 
> cleanEx()
> nameEx("pairwise.wilcox.test")
> ### * pairwise.wilcox.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: pairwise.wilcox.test
> ### Title: Pairwise Wilcoxon Rank Sum Tests
> ### Aliases: pairwise.wilcox.test
> ### Keywords: htest
> 
> ### ** Examples
> 
> attach(airquality)
> Month <- factor(Month, labels = month.abb[5:9])
> ## These give warnings because of ties :
> pairwise.wilcox.test(Ozone, Month)
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties

	Pairwise comparisons using Wilcoxon rank sum test with continuity correction 

data:  Ozone and Month 

    May    Jun    Jul    Aug   
Jun 0.5775 -      -      -     
Jul 0.0003 0.0848 -      -     
Aug 0.0011 0.1295 1.0000 -     
Sep 0.4744 1.0000 0.0060 0.0227

P value adjustment method: holm 
> pairwise.wilcox.test(Ozone, Month, p.adjust.method = "bonf")
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties
Warning in wilcox.test.default(xi, xj, paired = paired, ...) :
  cannot compute exact p-value with ties

	Pairwise comparisons using Wilcoxon rank sum test with continuity correction 

data:  Ozone and Month 

    May    Jun    Jul    Aug   
Jun 1.0000 -      -      -     
Jul 0.0003 0.1414 -      -     
Aug 0.0012 0.2591 1.0000 -     
Sep 1.0000 1.0000 0.0074 0.0325

P value adjustment method: bonferroni 
> detach()
> 
> 
> 
> cleanEx()
> nameEx("plot.acf")
> ### * plot.acf
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: plot.acf
> ### Title: Plot Autocovariance and Autocorrelation Functions
> ### Aliases: plot.acf
> ### Keywords: hplot ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> z4  <- ts(matrix(rnorm(400), 100, 4), start = c(1961, 1), frequency = 12)
> z7  <- ts(matrix(rnorm(700), 100, 7), start = c(1961, 1), frequency = 12)
> acf(z4)
> acf(z7, max.mfrow = 7)   # squeeze onto 1 page
> acf(z7) # multi-page
> 
> 
> 
> cleanEx()
> nameEx("plot.isoreg")
> ### * plot.isoreg
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: plot.isoreg
> ### Title: Plot Method for isoreg Objects
> ### Aliases: plot.isoreg lines.isoreg
> ### Keywords: hplot print
> 
> ### ** Examples
> 
> require(graphics)
> 
> utils::example(isoreg) # for the examples there

isoreg> require(graphics)

isoreg> (ir <- isoreg(c(1,0,4,3,3,5,4,2,0)))
Isotonic regression from isoreg(x = c(1, 0, 4, 3, 3, 5, 4, 2, 0)),
  with 2 knots / breaks at obs.nr. 2 9 ;
  initially ordered 'x'
  and further components List of 4
 $ x : num [1:9] 1 2 3 4 5 6 7 8 9
 $ y : num [1:9] 1 0 4 3 3 5 4 2 0
 $ yf: num [1:9] 0.5 0.5 3 3 3 3 3 3 3
 $ yc: num [1:10] 0 1 1 5 8 11 16 20 22 22

isoreg> plot(ir, plot.type = "row")

isoreg> (ir3 <- isoreg(y3 <- c(1,0,4,3,3,5,4,2, 3))) # last "3", not "0"
Isotonic regression from isoreg(x = y3 <- c(1, 0, 4, 3, 3, 5, 4, 2, 3)),
  with 3 knots / breaks at obs.nr. 2 5 9 ;
  initially ordered 'x'
  and further components List of 4
 $ x : num [1:9] 1 2 3 4 5 6 7 8 9
 $ y : num [1:9] 1 0 4 3 3 5 4 2 3
 $ yf: num [1:9] 0.5 0.5 3.33 3.33 3.33 ...
 $ yc: num [1:10] 0 1 1 5 8 11 16 20 22 25

isoreg> (fi3 <- as.stepfun(ir3))
Step function
Call: isoreg(x = y3 <- c(1, 0, 4, 3, 3, 5, 4, 2, 3))
 x[1:3] =      2,      5,      9
4 plateau levels =    0.5,    0.5, 3.3333,    3.5

isoreg> (ir4 <- isoreg(1:10, y4 <- c(5, 9, 1:2, 5:8, 3, 8)))
Isotonic regression from isoreg(x = 1:10, y = y4 <- c(5, 9, 1:2, 5:8, 3, 8)),
  with 5 knots / breaks at obs.nr. 4 5 6 9 10 ;
  initially ordered 'x'
  and further components List of 4
 $ x : num [1:10] 1 2 3 4 5 6 7 8 9 10
 $ y : num [1:10] 5 9 1 2 5 6 7 8 3 8
 $ yf: num [1:10] 4.25 4.25 4.25 4.25 5 6 6 6 6 8
 $ yc: num [1:11] 0 5 14 15 17 22 28 35 43 46 ...

isoreg> cat(sprintf("R^2 = %.2f\n",
isoreg+             1 - sum(residuals(ir4)^2) / ((10-1)*var(y4))))
R^2 = 0.21

isoreg> ## If you are interested in the knots alone :
isoreg> with(ir4, cbind(iKnots, yf[iKnots]))
     iKnots     
[1,]      4 4.25
[2,]      5 5.00
[3,]      6 6.00
[4,]      9 6.00
[5,]     10 8.00

isoreg> ## Example of unordered x[] with ties:
isoreg> x <- sample((0:30)/8)

isoreg> y <- exp(x)

isoreg> x. <- round(x) # ties!

isoreg> plot(m <- isoreg(x., y))

isoreg> stopifnot(all.equal(with(m, yf[iKnots]),
isoreg+                     as.vector(tapply(y, x., mean))))
> 
> plot(y3, main = "simple plot(.)  +  lines(<isoreg>)")
> lines(ir3)
> 
> ## 'same' plot as above, "proving" that only ranks of 'x' are important
> plot(isoreg(2^(1:9), c(1,0,4,3,3,5,4,2,0)), plot.type = "row", log = "x")
Warning in xy.coords(x, y, xlabel, ylabel, log) :
  1 x value <= 0 omitted from logarithmic plot
Warning in xy.coords(x, y, xlabel, ylabel, log) :
  1 x value <= 0 omitted from logarithmic plot
> 
> plot(ir3, plot.type = "row", ylab = "y3")
> plot(isoreg(y3 - 4), plot.type = "r", ylab = "y3 - 4")
> plot(ir4, plot.type = "ro",  ylab = "y4", xlab = "x = 1:n")
> 
> ## experiment a bit with these (C-c C-j):
> plot(isoreg(sample(9),  y3), plot.type = "row")
> plot(isoreg(sample(9),  y3), plot.type = "col.wise")
> 
> plot(ir <- isoreg(sample(10), sample(10, replace = TRUE)),
+                   plot.type = "r")
> 
> 
> 
> cleanEx()
> nameEx("plot.lm")
> ### * plot.lm
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: plot.lm
> ### Title: Plot Diagnostics for an 'lm' Object
> ### Aliases: plot.lm
> ### Keywords: hplot regression
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## Analysis of the life-cycle savings data
> ## given in Belsley, Kuh and Welsch.
> lm.SR <- lm(sr ~ pop15 + pop75 + dpi + ddpi, data = LifeCycleSavings)
> plot(lm.SR)
> 
> ## 4 plots on 1 page;
> ## allow room for printing model formula in outer margin:
> par(mfrow = c(2, 2), oma = c(0, 0, 2, 0)) -> opar
> plot(lm.SR)
> plot(lm.SR, id.n = NULL)                 # no id's
> plot(lm.SR, id.n = 5, labels.id = NULL)  # 5 id numbers
> 
> ## Was default in R <= 2.1.x:
> ## Cook's distances instead of Residual-Leverage plot
> plot(lm.SR, which = 1:4)
> 
> ## All the above fit a smooth curve where applicable
> ## by default unless "add.smooth" is changed.
> ## Give a smoother curve by increasing the lowess span :
> plot(lm.SR, panel = function(x, y) panel.smooth(x, y, span = 1))
> 
> par(mfrow = c(2,1)) # same oma as above
> plot(lm.SR, which = 1:2, sub.caption = "Saving Rates, n=50, p=5")
> 
> ## Cook's distance tweaking
> par(mfrow = c(2,3)) # same oma ...
> plot(lm.SR, which = 1:6, cook.col = "royalblue")
> 
> ## A case where over plotting of the "legend" is to be avoided:
> if(dev.interactive(TRUE)) getOption("device")(height = 6, width = 4)
> par(mfrow = c(3,1), mar = c(5,5,4,2)/2 +.1, mgp = c(1.4, .5, 0))
> plot(lm.SR, which = 5, extend.ylim.f = c(0.2, 0.08))
> plot(lm.SR, which = 5, cook.lty = "dotdash",
+      cook.legendChanges = list(x = "bottomright", legend = "Cook"))
> plot(lm.SR, which = 5, cook.legendChanges = NULL)  # no "legend"
> 
> ## Don't show: 
> ## An example with *long* formula that needs abbreviation:
> par(mfrow = c(2,2))
> for(i in 1:5) assign(paste("long.var.name", i, sep = "."), runif(10))
> plot(lm(long.var.name.1 ~
+         long.var.name.2 + long.var.name.3 + long.var.name.4 + long.var.name.5))
> ## End(Don't show)
> par(opar) # reset par()s
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("plot.ppr")
> ### * plot.ppr
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: plot.ppr
> ### Title: Plot Ridge Functions for Projection Pursuit Regression Fit
> ### Aliases: plot.ppr
> ### Keywords: hplot
> 
> ### ** Examples
> 
> require(graphics)
> 
> rock1 <- within(rock, { area1 <- area/10000; peri1 <- peri/10000 })
> par(mfrow = c(3,2)) # maybe: , pty = "s"
> rock.ppr <- ppr(log(perm) ~ area1 + peri1 + shape,
+                 data = rock1, nterms = 2, max.terms = 5)
> plot(rock.ppr, main = "ppr(log(perm)~ ., nterms=2, max.terms=5)")
> plot(update(rock.ppr, bass = 5), main = "update(..., bass = 5)")
> plot(update(rock.ppr, sm.method = "gcv", gcvpen = 2),
+      main = "update(..., sm.method=\"gcv\", gcvpen=2)")
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("plot.profile.nls")
> ### * plot.profile.nls
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: plot.profile.nls
> ### Title: Plot a profile.nls Object
> ### Aliases: plot.profile.nls
> ### Keywords: nonlinear regression models
> 
> ### ** Examples
> 
> require(graphics)
> 
> # obtain the fitted object
> fm1 <- nls(demand ~ SSasympOrig(Time, A, lrc), data = BOD)
> # get the profile for the fitted model
> pr1 <- profile(fm1, alphamax = 0.05)
> opar <- par(mfrow = c(2,2), oma = c(1.1, 0, 1.1, 0), las = 1)
> plot(pr1, conf = c(95, 90, 80, 50)/100)
> plot(pr1, conf = c(95, 90, 80, 50)/100, absVal = FALSE)
> mtext("Confidence intervals based on the profile sum of squares",
+       side = 3, outer = TRUE)
> mtext("BOD data - confidence levels of 50%, 80%, 90% and 95%",
+       side = 1, outer = TRUE)
> par(opar)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("plot.stepfun")
> ### * plot.stepfun
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: plot.stepfun
> ### Title: Plot Step Functions
> ### Aliases: plot.stepfun lines.stepfun
> ### Keywords: hplot
> 
> ### ** Examples
> 
> require(graphics)
> 
> y0 <- c(1,2,4,3)
> sfun0  <- stepfun(1:3, y0, f = 0)
> sfun.2 <- stepfun(1:3, y0, f = .2)
> sfun1  <- stepfun(1:3, y0, right = TRUE)
> 
> tt <- seq(0, 3, by = 0.1)
> op <- par(mfrow = c(2,2))
> plot(sfun0); plot(sfun0, xval = tt, add = TRUE, col.hor = "bisque")
> plot(sfun.2);plot(sfun.2, xval = tt, add = TRUE, col = "orange") # all colors
> plot(sfun1);lines(sfun1, xval = tt, col.hor = "coral")
> ##-- This is  revealing :
> plot(sfun0, verticals = FALSE,
+      main = "stepfun(x, y0, f=f)  for f = 0, .2, 1")
> for(i in 1:3)
+   lines(list(sfun0, sfun.2, stepfun(1:3, y0, f = 1))[[i]], col = i)
> legend(2.5, 1.9, paste("f =", c(0, 0.2, 1)), col = 1:3, lty = 1, y.intersp = 1)
> par(op)
> 
> # Extend and/or restrict 'viewport':
> plot(sfun0, xlim = c(0,5), ylim = c(0, 3.5),
+      main = "plot(stepfun(*), xlim= . , ylim = .)")
> 
> ##-- this works too (automatic call to  ecdf(.)):
> plot.stepfun(rt(50, df = 3), col.vert = "gray20")
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("plot.ts")
> ### * plot.ts
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: plot.ts
> ### Title: Plotting Time-Series Objects
> ### Aliases: plot.ts lines.ts
> ### Keywords: hplot ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## Multivariate
> z <- ts(matrix(rt(200 * 8, df = 3), 200, 8),
+         start = c(1961, 1), frequency = 12)
> plot(z, yax.flip = TRUE)
> plot(z, axes = FALSE, ann = FALSE, frame.plot = TRUE,
+      mar.multi = c(0,0,0,0), oma.multi = c(1,1,5,1))
> title("plot(ts(..), axes=FALSE, ann=FALSE, frame.plot=TRUE, mar..., oma...)")
> 
> z <- window(z[,1:3], end = c(1969,12))
> plot(z, type = "b")    # multiple
> plot(z, plot.type = "single", lty = 1:3, col = 4:2)
> 
> ## A phase plot:
> plot(nhtemp, lag(nhtemp, 1), cex = .8, col = "blue",
+      main = "Lag plot of New Haven temperatures")
> 
> ## xy.lines and xy.labels are FALSE for large series:
> plot(lag(sunspots, 1), sunspots, pch = ".")
> 
> SMI <- EuStockMarkets[, "SMI"]
> plot(lag(SMI,  1), SMI, pch = ".")
> plot(lag(SMI, 20), SMI, pch = ".", log = "xy",
+      main = "4 weeks lagged SMI stocks -- log scale", xy.lines =  TRUE)
> 
> 
> 
> cleanEx()
> nameEx("poisson.test")
> ### * poisson.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: poisson.test
> ### Title: Exact Poisson tests
> ### Aliases: poisson.test
> ### Keywords: htest
> 
> ### ** Examples
> 
> ### These are paraphrased from data sets in the ISwR package
> 
> ## SMR, Welsh Nickel workers
> poisson.test(137, 24.19893)

	Exact Poisson test

data:  137 time base: 24.19893
number of events = 137, time base = 24.199, p-value < 2.2e-16
alternative hypothesis: true event rate is not equal to 1
95 percent confidence interval:
 4.753125 6.692709
sample estimates:
event rate 
  5.661407 

> 
> ## eba1977, compare Fredericia to other three cities for ages 55-59
> poisson.test(c(11, 6+8+7), c(800, 1083+1050+878))

	Comparison of Poisson rates

data:  c(11, 6 + 8 + 7) time base: c(800, 1083 + 1050 + 878)
count1 = 11, expected count1 = 6.7174, p-value = 0.07967
alternative hypothesis: true rate ratio is not equal to 1
95 percent confidence interval:
 0.8584264 4.2772659
sample estimates:
rate ratio 
  1.971488 

> 
> 
> 
> cleanEx()
> nameEx("poly")
> ### * poly
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: poly
> ### Title: Compute Orthogonal Polynomials
> ### Aliases: poly polym predict.poly makepredictcall.poly
> ### Keywords: math
> 
> ### ** Examples
> 
> od <- options(digits = 3) # avoid too much visual clutter
> (z <- poly(1:10, 3))
           1      2      3
 [1,] -0.495  0.522 -0.453
 [2,] -0.385  0.174  0.151
 [3,] -0.275 -0.087  0.378
 [4,] -0.165 -0.261  0.335
 [5,] -0.055 -0.348  0.130
 [6,]  0.055 -0.348 -0.130
 [7,]  0.165 -0.261 -0.335
 [8,]  0.275 -0.087 -0.378
 [9,]  0.385  0.174 -0.151
[10,]  0.495  0.522  0.453
attr(,"coefs")
attr(,"coefs")$alpha
[1] 5.5 5.5 5.5

attr(,"coefs")$norm2
[1]    1.0   10.0   82.5  528.0 3088.8

attr(,"degree")
[1] 1 2 3
attr(,"class")
[1] "poly"   "matrix"
> predict(z, seq(2, 4, 0.5))
          1       2     3
[1,] -0.385  0.1741 0.151
[2,] -0.330  0.0326 0.305
[3,] -0.275 -0.0870 0.378
[4,] -0.220 -0.1850 0.383
[5,] -0.165 -0.2611 0.335
> zapsmall(poly(seq(4, 6, 0.5), 3, coefs = attr(z, "coefs")))
          1      2      3
[1,] -0.165 -0.261  0.335
[2,] -0.110 -0.316  0.246
[3,] -0.055 -0.348  0.130
[4,]  0.000 -0.359  0.000
[5,]  0.055 -0.348 -0.130
attr(,"coefs")
attr(,"coefs")$alpha
[1] 5.5 5.5 5.5

attr(,"coefs")$norm2
[1]    1.0   10.0   82.5  528.0 3088.8

attr(,"degree")
[1] 1 2 3
attr(,"class")
[1] "poly"   "matrix"
> 
>  zm <- zapsmall(polym (    1:4, c(1, 4:6),  degree = 3)) # or just poly():
> (z1 <- zapsmall(poly(cbind(1:4, c(1, 4:6)), degree = 3)))
        1.0  2.0    3.0    0.1   1.1    2.1    0.2    1.2    0.3
[1,] -0.671  0.5 -0.224 -0.802 0.538 -0.401  0.323 -0.217 -0.053
[2,] -0.224 -0.5  0.671  0.000 0.000  0.000 -0.688  0.154  0.526
[3,]  0.224 -0.5 -0.671  0.267 0.060 -0.134 -0.239 -0.053 -0.788
[4,]  0.671  0.5  0.224  0.535 0.359  0.267  0.604  0.405  0.315
attr(,"degree")
[1] 1 2 3 1 2 3 2 3 3
attr(,"coefs")
attr(,"coefs")[[1]]
attr(,"coefs")[[1]]$alpha
[1] 2.5 2.5 2.5

attr(,"coefs")[[1]]$norm2
[1] 1.0 4.0 5.0 4.0 1.8


attr(,"coefs")[[2]]
attr(,"coefs")[[2]]$alpha
[1] 4.00 2.71 4.47

attr(,"coefs")[[2]]$norm2
[1]  1.00  4.00 14.00 25.86  9.94


attr(,"class")
[1] "poly"   "matrix"
> ## they are the same :
> stopifnot(all.equal(zm, z1, tolerance = 1e-15))
> 
> ## poly(<matrix>, df) --- used to fail till July 14 (vive la France!), 2017:
> m2 <- cbind(1:4, c(1, 4:6))
> pm2 <- zapsmall(poly(m2, 3)) # "unnamed degree = 3"
> stopifnot(all.equal(pm2, zm, tolerance = 1e-15))
> 
> options(od)
> 
> 
> 
> cleanEx()
> nameEx("power")
> ### * power
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: power
> ### Title: Create a Power Link Object
> ### Aliases: power
> ### Keywords: models
> 
> ### ** Examples
> 
> power()
$linkfun
function (mu) 
mu
<environment: namespace:stats>

$linkinv
function (eta) 
eta
<environment: namespace:stats>

$mu.eta
function (eta) 
rep.int(1, length(eta))
<environment: namespace:stats>

$valideta
function (eta) 
TRUE
<environment: namespace:stats>

$name
[1] "identity"

attr(,"class")
[1] "link-glm"
> quasi(link = power(1/3))[c("linkfun", "linkinv")]
$linkfun
function (mu) 
mu^lambda
<bytecode: 0x65bdfe0>
<environment: 0x65c9218>

$linkinv
function (eta) 
pmax(eta^(1/lambda), .Machine$double.eps)
<bytecode: 0x65bde90>
<environment: 0x65c9218>

> 
> 
> 
> cleanEx()
> nameEx("power.anova.test")
> ### * power.anova.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: power.anova.test
> ### Title: Power Calculations for Balanced One-Way Analysis of Variance
> ###   Tests
> ### Aliases: power.anova.test
> ### Keywords: htest
> 
> ### ** Examples
> 
> power.anova.test(groups = 4, n = 5, between.var = 1, within.var = 3)

     Balanced one-way analysis of variance power calculation 

         groups = 4
              n = 5
    between.var = 1
     within.var = 3
      sig.level = 0.05
          power = 0.3535594

NOTE: n is number in each group

> # Power = 0.3535594
> 
> power.anova.test(groups = 4, between.var = 1, within.var = 3,
+                  power = .80)

     Balanced one-way analysis of variance power calculation 

         groups = 4
              n = 11.92613
    between.var = 1
     within.var = 3
      sig.level = 0.05
          power = 0.8

NOTE: n is number in each group

> # n = 11.92613
> 
> ## Assume we have prior knowledge of the group means:
> groupmeans <- c(120, 130, 140, 150)
> power.anova.test(groups = length(groupmeans),
+                  between.var = var(groupmeans),
+                  within.var = 500, power = .90) # n = 15.18834

     Balanced one-way analysis of variance power calculation 

         groups = 4
              n = 15.18834
    between.var = 166.6667
     within.var = 500
      sig.level = 0.05
          power = 0.9

NOTE: n is number in each group

> 
> 
> 
> cleanEx()
> nameEx("power.prop.test")
> ### * power.prop.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: power.prop.test
> ### Title: Power Calculations for Two-Sample Test for Proportions
> ### Aliases: power.prop.test
> ### Keywords: htest
> 
> ### ** Examples
> 
> power.prop.test(n = 50, p1 = .50, p2 = .75)      ## => power = 0.740

     Two-sample comparison of proportions power calculation 

              n = 50
             p1 = 0.5
             p2 = 0.75
      sig.level = 0.05
          power = 0.7401659
    alternative = two.sided

NOTE: n is number in *each* group

> power.prop.test(p1 = .50, p2 = .75, power = .90) ## =>     n = 76.7

     Two-sample comparison of proportions power calculation 

              n = 76.70693
             p1 = 0.5
             p2 = 0.75
      sig.level = 0.05
          power = 0.9
    alternative = two.sided

NOTE: n is number in *each* group

> power.prop.test(n = 50, p1 = .5, power = .90)    ## =>    p2 = 0.8026

     Two-sample comparison of proportions power calculation 

              n = 50
             p1 = 0.5
             p2 = 0.8026141
      sig.level = 0.05
          power = 0.9
    alternative = two.sided

NOTE: n is number in *each* group

> power.prop.test(n = 50, p1 = .5, p2 = 0.9, power = .90, sig.level=NULL)

     Two-sample comparison of proportions power calculation 

              n = 50
             p1 = 0.5
             p2 = 0.9
      sig.level = 0.001318068
          power = 0.9
    alternative = two.sided

NOTE: n is number in *each* group

>                                                  ## => sig.l = 0.00131
> power.prop.test(p1 = .5, p2 = 0.501, sig.level=.001, power=0.90)

     Two-sample comparison of proportions power calculation 

              n = 10451937
             p1 = 0.5
             p2 = 0.501
      sig.level = 0.001
          power = 0.9
    alternative = two.sided

NOTE: n is number in *each* group

>                                                  ## => n = 10451937
> try(
+  power.prop.test(n=30, p1=0.90, p2=NULL, power=0.8)
+ ) # a warning  (which may become an error)
Warning in power.prop.test(n = 30, p1 = 0.9, p2 = NULL, power = 0.8) :
  No p2 in [p1, 1] can be found to achieve the desired power

     Two-sample comparison of proportions power calculation 

              n = 30
             p1 = 0.9
             p2 = 1.030182
      sig.level = 0.05
          power = 0.8
    alternative = two.sided

NOTE: n is number in *each* group

> ## Reason:
> power.prop.test(      p1=0.90, p2= 1.0, power=0.8) ##-> n = 73.37

     Two-sample comparison of proportions power calculation 

              n = 73.37427
             p1 = 0.9
             p2 = 1
      sig.level = 0.05
          power = 0.8
    alternative = two.sided

NOTE: n is number in *each* group

> 
> 
> 
> cleanEx()
> nameEx("power.t.test")
> ### * power.t.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: power.t.test
> ### Title: Power calculations for one and two sample t tests
> ### Aliases: power.t.test
> ### Keywords: htest
> 
> ### ** Examples
> 
>  power.t.test(n = 20, delta = 1)

     Two-sample t test power calculation 

              n = 20
          delta = 1
             sd = 1
      sig.level = 0.05
          power = 0.8689528
    alternative = two.sided

NOTE: n is number in *each* group

>  power.t.test(power = .90, delta = 1)

     Two-sample t test power calculation 

              n = 22.0211
          delta = 1
             sd = 1
      sig.level = 0.05
          power = 0.9
    alternative = two.sided

NOTE: n is number in *each* group

>  power.t.test(power = .90, delta = 1, alternative = "one.sided")

     Two-sample t test power calculation 

              n = 17.84713
          delta = 1
             sd = 1
      sig.level = 0.05
          power = 0.9
    alternative = one.sided

NOTE: n is number in *each* group

> 
> 
> 
> cleanEx()
> nameEx("pp.test")
> ### * pp.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: PP.test
> ### Title: Phillips-Perron Test for Unit Roots
> ### Aliases: PP.test
> ### Keywords: ts
> 
> ### ** Examples
> 
> x <- rnorm(1000)
> PP.test(x)

	Phillips-Perron Unit Root Test

data:  x
Dickey-Fuller = -33.057, Truncation lag parameter = 7, p-value = 0.01

> y <- cumsum(x) # has unit root
> PP.test(y)

	Phillips-Perron Unit Root Test

data:  y
Dickey-Fuller = -2.6899, Truncation lag parameter = 7, p-value = 0.2863

> 
> 
> 
> cleanEx()
> nameEx("ppoints")
> ### * ppoints
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ppoints
> ### Title: Ordinates for Probability Plotting
> ### Aliases: ppoints
> ### Keywords: dplot arith distribution
> 
> ### ** Examples
> 
> ppoints(4) # the same as  ppoints(1:4)
[1] 0.1470588 0.3823529 0.6176471 0.8529412
> ppoints(10)
 [1] 0.06097561 0.15853659 0.25609756 0.35365854 0.45121951 0.54878049
 [7] 0.64634146 0.74390244 0.84146341 0.93902439
> ppoints(10, a = 1/2)
 [1] 0.05 0.15 0.25 0.35 0.45 0.55 0.65 0.75 0.85 0.95
> 
> ## Visualize including the fractions :
> require(graphics)## Don't show: 
> lNs <- loadedNamespaces()
> ## End(Don't show)
> p.ppoints <- function(n, ..., add = FALSE, col = par("col")) {
+   pn <- ppoints(n, ...)
+   if(add)
+       points(pn, pn, col = col)
+   else {
+       tit <- match.call(); tit[[1]] <- quote(ppoints)
+       plot(pn,pn, main = deparse(tit), col=col,
+            xlim = 0:1, ylim = 0:1, xaxs = "i", yaxs = "i")
+       abline(0, 1, col = adjustcolor(1, 1/4), lty = 3)
+   }
+   if(!add && requireNamespace("MASS", quietly = TRUE))
+     text(pn, pn, as.character(MASS::fractions(pn)),
+          adj = c(0,0)-1/4, cex = 3/4, xpd = NA, col=col)
+   abline(h = pn, v = pn, col = adjustcolor(col, 1/2), lty = 2, lwd = 1/2)
+ }
> 
> p.ppoints(4)
> p.ppoints(10)
> p.ppoints(10, a = 1/2)
> p.ppoints(21)
> p.ppoints(8) ; p.ppoints(8, a = 1/2, add=TRUE, col="tomato")
> ## Don't show: 
> if(!any("MASS" == lNs)) unloadNamespace("MASS")
> ## End(Don't show)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("ppr")
> ### * ppr
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ppr
> ### Title: Projection Pursuit Regression
> ### Aliases: ppr ppr.default ppr.formula
> ### Keywords: regression
> 
> ### ** Examples
> 
> require(graphics)
> 
> # Note: your numerical values may differ
> attach(rock)
> area1 <- area/10000; peri1 <- peri/10000
> rock.ppr <- ppr(log(perm) ~ area1 + peri1 + shape,
+                 data = rock, nterms = 2, max.terms = 5)
> rock.ppr
Call:
ppr(formula = log(perm) ~ area1 + peri1 + shape, data = rock, 
    nterms = 2, max.terms = 5)

Goodness of fit:
 2 terms  3 terms  4 terms  5 terms 
8.737806 5.289517 4.745799 4.490378 
> # Call:
> # ppr.formula(formula = log(perm) ~ area1 + peri1 + shape, data = rock,
> #     nterms = 2, max.terms = 5)
> #
> # Goodness of fit:
> #  2 terms  3 terms  4 terms  5 terms
> # 8.737806 5.289517 4.745799 4.490378
> 
> summary(rock.ppr)
Call:
ppr(formula = log(perm) ~ area1 + peri1 + shape, data = rock, 
    nterms = 2, max.terms = 5)

Goodness of fit:
 2 terms  3 terms  4 terms  5 terms 
8.737806 5.289517 4.745799 4.490378 

Projection direction vectors ('alpha'):
      term 1      term 2     
area1  0.34357179  0.37071027
peri1 -0.93781471 -0.61923542
shape  0.04961846  0.69218595

Coefficients of ridge terms ('beta'):
   term 1    term 2 
1.6079271 0.5460971 
> # .....  (same as above)
> # .....
> #
> # Projection direction vectors ('alpha'):
> #       term 1      term 2
> # area1  0.34357179  0.37071027
> # peri1 -0.93781471 -0.61923542
> # shape  0.04961846  0.69218595
> #
> # Coefficients of ridge terms:
> #    term 1    term 2
> # 1.6079271 0.5460971
> 
> par(mfrow = c(3,2))   # maybe: , pty = "s")
> plot(rock.ppr, main = "ppr(log(perm)~ ., nterms=2, max.terms=5)")
> plot(update(rock.ppr, bass = 5), main = "update(..., bass = 5)")
> plot(update(rock.ppr, sm.method = "gcv", gcvpen = 2),
+      main = "update(..., sm.method=\"gcv\", gcvpen=2)")
> cbind(perm = rock$perm, prediction = round(exp(predict(rock.ppr)), 1))
     perm prediction
1     6.3        5.9
2     6.3        6.5
3     6.3       12.1
4     6.3        7.4
5    17.1       16.3
6    17.1       13.2
7    17.1       41.2
8    17.1       10.6
9   119.0      101.9
10  119.0       73.0
11  119.0       46.8
12  119.0      121.7
13   82.4      107.8
14   82.4       79.7
15   82.4       98.3
16   82.4      128.8
17   58.6       66.8
18   58.6       33.2
19   58.6       58.7
20   58.6      111.6
21  142.0      118.9
22  142.0      128.4
23  142.0       91.9
24  142.0      188.5
25  740.0      341.7
26  740.0      577.9
27  740.0      895.7
28  740.0     1041.0
29  890.0      560.8
30  890.0      721.8
31  890.0      937.9
32  890.0      848.5
33  950.0      806.4
34  950.0     1085.4
35  950.0      945.6
36  950.0      848.5
37  100.0      154.1
38  100.0      178.0
39  100.0      321.5
40  100.0      232.7
41 1300.0     1067.0
42 1300.0      697.8
43 1300.0     1236.6
44 1300.0     1301.8
45  580.0      485.1
46  580.0      285.1
47  580.0      644.3
48  580.0      571.5
> detach()
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("prcomp")
> ### * prcomp
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: prcomp
> ### Title: Principal Components Analysis
> ### Aliases: prcomp prcomp.formula prcomp.default plot.prcomp
> ###   predict.prcomp print.prcomp summary.prcomp print.summary.prcomp
> ### Keywords: multivariate
> 
> ### ** Examples
> 
> C <- chol(S <- toeplitz(.9 ^ (0:31))) # Cov.matrix and its root
> all.equal(S, crossprod(C))
[1] TRUE
> set.seed(17)
> X <- matrix(rnorm(32000), 1000, 32)
> Z <- X %*% C  ## ==>  cov(Z) ~=  C'C = S
> all.equal(cov(Z), S, tolerance = 0.08)
[1] TRUE
> pZ <- prcomp(Z, tol = 0.1)
> summary(pZ) # only ~14 PCs (out of 32)
Importance of first k=14 (out of 32) components:
                          PC1    PC2    PC3     PC4     PC5     PC6     PC7
Standard deviation     3.6415 2.7178 1.8447 1.39430 1.10207 0.90922 0.76951
Proportion of Variance 0.4173 0.2324 0.1071 0.06118 0.03822 0.02602 0.01864
Cumulative Proportion  0.4173 0.6498 0.7569 0.81806 0.85628 0.88230 0.90094
                           PC8     PC9    PC10    PC11    PC12    PC13   PC14
Standard deviation     0.67490 0.60833 0.51638 0.49048 0.44452 0.40326 0.3904
Proportion of Variance 0.01433 0.01165 0.00839 0.00757 0.00622 0.00512 0.0048
Cumulative Proportion  0.91527 0.92692 0.93531 0.94288 0.94910 0.95422 0.9590
> ## or choose only 3 PCs more directly:
> pz3 <- prcomp(Z, rank. = 3)
> summary(pz3) # same numbers as the first 3 above
Importance of first k=3 (out of 32) components:
                          PC1    PC2    PC3
Standard deviation     3.6415 2.7178 1.8447
Proportion of Variance 0.4173 0.2324 0.1071
Cumulative Proportion  0.4173 0.6498 0.7569
> stopifnot(ncol(pZ$rotation) == 14, ncol(pz3$rotation) == 3,
+           all.equal(pz3$sdev, pZ$sdev, tolerance = 1e-15)) # exactly equal typically
> 
> 
> 
> 
> cleanEx()
> nameEx("predict.HoltWinters")
> ### * predict.HoltWinters
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: predict.HoltWinters
> ### Title: Prediction Function for Fitted Holt-Winters Models
> ### Aliases: predict.HoltWinters
> ### Keywords: ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> m <- HoltWinters(co2)
> p <- predict(m, 50, prediction.interval = TRUE)
> plot(m, p)
> 
> 
> 
> cleanEx()
> nameEx("predict")
> ### * predict
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: predict
> ### Title: Model Predictions
> ### Aliases: predict
> ### Keywords: methods
> 
> ### ** Examples
> 
> ## Don't show: 
> old <- Sys.getlocale("LC_COLLATE")
>        invisible(Sys.setlocale("LC_COLLATE", "C"))
> ## End(Don't show)
> require(utils)
> 
> ## All the "predict" methods found
> ## NB most of the methods in the standard packages are hidden.
> ## Output will depend on what namespaces are (or have been) loaded.
> ## IGNORE_RDIFF_BEGIN
> for(fn in methods("predict"))
+    try({
+        f <- eval(substitute(getAnywhere(fn)$objs[[1]], list(fn = fn)))
+        cat(fn, ":\n\t", deparse(args(f)), "\n")
+        }, silent = TRUE)
predict.Arima :
	 function (object, n.ahead = 1L, newxreg = NULL, se.fit = TRUE,      ...)  NULL 
predict.HoltWinters :
	 function (object, n.ahead = 1L, prediction.interval = FALSE,      level = 0.95, ...)  NULL 
predict.StructTS :
	 function (object, n.ahead = 1L, se.fit = TRUE, ...)  NULL 
predict.ar :
	 function (object, newdata, n.ahead = 1L, se.fit = TRUE, ...)  NULL 
predict.arima0 :
	 function (object, n.ahead = 1L, newxreg = NULL, se.fit = TRUE,      ...)  NULL 
predict.bSpline :
	 function (object, x, nseg = 50, deriv = 0, ...)  NULL 
predict.bs :
	 function (object, newx, ...)  NULL 
predict.glm :
	 function (object, newdata = NULL, type = c("link", "response",      "terms"), se.fit = FALSE, dispersion = NULL, terms = NULL,      na.action = na.pass, ...)  NULL 
predict.glmmPQL :
	 function (object, newdata = NULL, type = c("link", "response"),      level = Q, na.action = na.pass, ...)  NULL 
predict.lda :
	 function (object, newdata, prior = object$prior, dimen, method = c("plug-in",      "predictive", "debiased"), ...)  NULL 
predict.lm :
	 function (object, newdata, se.fit = FALSE, scale = NULL, df = Inf,      interval = c("none", "confidence", "prediction"), level = 0.95,      type = c("response", "terms"), terms = NULL, na.action = na.pass,      pred.var = res.var/weights, weights = 1, ...)  NULL 
predict.loess :
	 function (object, newdata = NULL, se = FALSE, na.action = na.pass,      ...)  NULL 
predict.lqs :
	 function (object, newdata, na.action = na.pass, ...)  NULL 
predict.mca :
	 function (object, newdata, type = c("row", "factor"), ...)  NULL 
predict.mlm :
	 function (object, newdata, se.fit = FALSE, na.action = na.pass,      ...)  NULL 
predict.nbSpline :
	 function (object, x, nseg = 50, deriv = 0, ...)  NULL 
predict.nls :
	 function (object, newdata, se.fit = FALSE, scale = NULL, df = Inf,      interval = c("none", "confidence", "prediction"), level = 0.95,      ...)  NULL 
predict.npolySpline :
	 function (object, x, nseg = 50, deriv = 0, ...)  NULL 
predict.ns :
	 function (object, newx, ...)  NULL 
predict.pbSpline :
	 function (object, x, nseg = 50, deriv = 0, ...)  NULL 
predict.polr :
	 function (object, newdata, type = c("class", "probs"), ...)  NULL 
predict.poly :
	 function (object, newdata, ...)  NULL 
predict.polySpline :
	 function (object, x, nseg = 50, deriv = 0, ...)  NULL 
predict.ppolySpline :
	 function (object, x, nseg = 50, deriv = 0, ...)  NULL 
predict.ppr :
	 function (object, newdata, ...)  NULL 
predict.prcomp :
	 function (object, newdata, ...)  NULL 
predict.princomp :
	 function (object, newdata, ...)  NULL 
predict.qda :
	 function (object, newdata, prior = object$prior, method = c("plug-in",      "predictive", "debiased", "looCV"), ...)  NULL 
predict.rlm :
	 function (object, newdata = NULL, scale = NULL, ...)  NULL 
predict.smooth.spline :
	 function (object, x, deriv = 0, ...)  NULL 
predict.smooth.spline.fit :
	 function (object, x, deriv = 0, ...)  NULL 
> ## IGNORE_RDIFF_END
> ## Don't show: 
> invisible(Sys.setlocale("LC_COLLATE", old))
> ## End(Don't show)
> 
> 
> 
> cleanEx()
> nameEx("predict.arima")
> ### * predict.arima
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: predict.Arima
> ### Title: Forecast from ARIMA fits
> ### Aliases: predict.Arima
> ### Keywords: ts
> 
> ### ** Examples
> 
> od <- options(digits = 5) # avoid too much spurious accuracy
> predict(arima(lh, order = c(3,0,0)), n.ahead = 12)
$pred
Time Series:
Start = 49 
End = 60 
Frequency = 1 
 [1] 2.4602 2.2708 2.1986 2.2607 2.3470 2.4145 2.4389 2.4315 2.4102 2.3917
[11] 2.3827 2.3827

$se
Time Series:
Start = 49 
End = 60 
Frequency = 1 
 [1] 0.42268 0.50293 0.52452 0.52472 0.53055 0.53692 0.53880 0.53884 0.53910
[10] 0.53952 0.53970 0.53971

> 
> (fit <- arima(USAccDeaths, order = c(0,1,1),
+               seasonal = list(order = c(0,1,1))))

Call:
arima(x = USAccDeaths, order = c(0, 1, 1), seasonal = list(order = c(0, 1, 1)))

Coefficients:
         ma1    sma1
      -0.430  -0.553
s.e.   0.123   0.178

sigma^2 estimated as 99347:  log likelihood = -425.44,  aic = 856.88
> predict(fit, n.ahead = 6)
$pred
        Jan    Feb    Mar    Apr    May    Jun
1979 8336.1 7531.8 8314.6 8616.9 9488.9 9859.8

$se
        Jan    Feb    Mar    Apr    May    Jun
1979 315.45 363.01 405.02 443.06 478.09 510.72

> options(od)
> 
> 
> 
> cleanEx()
> nameEx("predict.glm")
> ### * predict.glm
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: predict.glm
> ### Title: Predict Method for GLM Fits
> ### Aliases: predict.glm
> ### Keywords: models regression
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## example from Venables and Ripley (2002, pp. 190-2.)
> ldose <- rep(0:5, 2)
> numdead <- c(1, 4, 9, 13, 18, 20, 0, 2, 6, 10, 12, 16)
> sex <- factor(rep(c("M", "F"), c(6, 6)))
> SF <- cbind(numdead, numalive = 20-numdead)
> budworm.lg <- glm(SF ~ sex*ldose, family = binomial)
> summary(budworm.lg)

Call:
glm(formula = SF ~ sex * ldose, family = binomial)

Deviance Residuals: 
     Min        1Q    Median        3Q       Max  
-1.39849  -0.32094  -0.07592   0.38220   1.10375  

Coefficients:
            Estimate Std. Error z value Pr(>|z|)    
(Intercept)  -2.9935     0.5527  -5.416 6.09e-08 ***
sexM          0.1750     0.7783   0.225    0.822    
ldose         0.9060     0.1671   5.422 5.89e-08 ***
sexM:ldose    0.3529     0.2700   1.307    0.191    
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

(Dispersion parameter for binomial family taken to be 1)

    Null deviance: 124.8756  on 11  degrees of freedom
Residual deviance:   4.9937  on  8  degrees of freedom
AIC: 43.104

Number of Fisher Scoring iterations: 4

> 
> plot(c(1,32), c(0,1), type = "n", xlab = "dose",
+      ylab = "prob", log = "x")
> text(2^ldose, numdead/20, as.character(sex))
> ld <- seq(0, 5, 0.1)
> lines(2^ld, predict(budworm.lg, data.frame(ldose = ld,
+    sex = factor(rep("M", length(ld)), levels = levels(sex))),
+    type = "response"))
> lines(2^ld, predict(budworm.lg, data.frame(ldose = ld,
+    sex = factor(rep("F", length(ld)), levels = levels(sex))),
+    type = "response"))
> 
> 
> 
> cleanEx()
> nameEx("predict.lm")
> ### * predict.lm
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: predict.lm
> ### Title: Predict method for Linear Model Fits
> ### Aliases: predict.lm
> ### Keywords: regression
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## Predictions
> x <- rnorm(15)
> y <- x + rnorm(15)
> predict(lm(y ~ x))
         1          2          3          4          5          6          7 
-0.6270917  0.2550840 -0.8548779  1.7923222  0.4139268 -0.8383687  0.5858991 
         8          9         10         11         12         13         14 
 0.8591183  0.6821126 -0.2774594  1.7013932  0.4796306 -0.6214146 -2.3566523 
        15 
 1.2801229 
> new <- data.frame(x = seq(-3, 3, 0.5))
> predict(lm(y ~ x), new, se.fit = TRUE)
$fit
          1           2           3           4           5           6 
-3.21182462 -2.66733702 -2.12284942 -1.57836182 -1.03387422 -0.48938662 
          7           8           9          10          11          12 
 0.05510098  0.59958858  1.14407618  1.68856379  2.23305139  2.77753899 
         13 
 3.32202659 

$se.fit
        1         2         3         4         5         6         7         8 
0.7545246 0.6449274 0.5380108 0.4357521 0.3423511 0.2672616 0.2292452 0.2461261 
        9        10        11        12        13 
0.3090353 0.3966456 0.4960370 0.6013965 0.7100725 

$df
[1] 13

$residual.scale
[1] 0.8832292

> pred.w.plim <- predict(lm(y ~ x), new, interval = "prediction")
> pred.w.clim <- predict(lm(y ~ x), new, interval = "confidence")
> matplot(new$x, cbind(pred.w.clim, pred.w.plim[,-1]),
+         lty = c(1,2,2,3,3), type = "l", ylab = "predicted y")
> 
> ## Prediction intervals, special cases
> ##  The first three of these throw warnings
> w <- 1 + x^2
> fit <- lm(y ~ x)
> wfit <- lm(y ~ x, weights = w)
> predict(fit, interval = "prediction")
Warning in predict.lm(fit, interval = "prediction") :
  predictions on current data refer to _future_ responses

          fit        lwr         upr
1  -0.6270917 -2.6311852  1.37700188
2   0.2550840 -1.7160306  2.22619860
3  -0.8548779 -2.8806560  1.17090027
4   1.7923222 -0.3158417  3.90048609
5   0.4139268 -1.5600794  2.38793297
6  -0.8383687 -2.8624006  1.18566313
7   0.5858991 -1.3942769  2.56607519
8   0.8591183 -1.1372816  2.85551813
9   0.6821126 -1.3028836  2.66710884
10 -0.2774594 -2.2586227  1.70370390
11  1.7013932 -0.3922734  3.79505973
12  0.4796306 -1.4963611  2.45562227
13 -0.6214146 -2.6250348  1.38220556
14 -2.3566523 -4.6435457 -0.06975883
15  1.2801229 -0.7562734  3.31651909
> predict(wfit, interval = "prediction")
Warning in predict.lm(wfit, interval = "prediction") :
  predictions on current data refer to _future_ responses

Warning in predict.lm(wfit, interval = "prediction") :
  assuming prediction variance inversely proportional to weights used for fitting

          fit        lwr        upr
1  -0.6795401 -2.7152943  1.3562142
2   0.2726114 -2.0676598  2.6128825
3  -0.9253947 -2.7873163  0.9365269
4   1.9317861  0.5179227  3.3456495
5   0.4440538 -1.8206181  2.7087257
6  -0.9075760 -2.7817747  0.9666227
7   0.6296673 -1.5219043  2.7812390
8   0.9245587 -1.0206112  2.8697287
9   0.7335126 -1.3468740  2.8138992
10 -0.3021743 -2.5805044  1.9761557
11  1.8336444  0.3867018  3.2805870
12  0.5149694 -1.7094216  2.7393604
13 -0.6734127 -2.7135353  1.3667099
14 -2.5462925 -3.8073357 -1.2852494
15  1.3789581 -0.2749888  3.0329051
> predict(wfit, new, interval = "prediction")
Warning in predict.lm(wfit, new, interval = "prediction") :
  Assuming constant prediction variance even though model fit is weighted

           fit         lwr        upr
1  -3.46929871 -6.02669183 -0.9119056
2  -2.88162137 -5.38456191 -0.3786808
3  -2.29394403 -4.75159401  0.1637059
4  -1.70626669 -4.12830217  0.7157688
5  -1.11858935 -3.51511782  1.2779391
6  -0.53091201 -2.91236575  1.8505417
7   0.05676532 -2.32024444  2.4337751
8   0.64444266 -1.73881338  3.0276987
9   1.23212000 -1.16798909  3.6322291
10  1.81979734 -0.60755066  4.2471453
11  2.40747468 -0.05715376  4.8721031
12  2.99515202  0.48364874  5.5066553
13  3.58282936  1.01538228  6.1502764
> predict(wfit, new, interval = "prediction", weights = (new$x)^2)
           fit        lwr         upr
1  -3.46929871 -4.7661745 -2.17242292
2  -2.88162137 -4.1752786 -1.58796414
3  -2.29394403 -3.6870669 -0.90082115
4  -1.70626669 -3.3884596 -0.02407382
5  -1.11858935 -3.5151178  1.27793911
6  -0.53091201 -5.2286061  4.16678211
7   0.05676532       -Inf         Inf
8   0.64444266 -4.0541654  5.34305071
9   1.23212000 -1.1679891  3.63222909
10  1.81979734  0.1299644  3.50963027
11  2.40747468  1.0020775  3.81287188
12  2.99515202  1.6850045  4.30529950
13  3.58282936  2.2662384  4.89942029
> predict(wfit, new, interval = "prediction", weights = ~x^2)
           fit        lwr         upr
1  -3.46929871 -4.7661745 -2.17242292
2  -2.88162137 -4.1752786 -1.58796414
3  -2.29394403 -3.6870669 -0.90082115
4  -1.70626669 -3.3884596 -0.02407382
5  -1.11858935 -3.5151178  1.27793911
6  -0.53091201 -5.2286061  4.16678211
7   0.05676532       -Inf         Inf
8   0.64444266 -4.0541654  5.34305071
9   1.23212000 -1.1679891  3.63222909
10  1.81979734  0.1299644  3.50963027
11  2.40747468  1.0020775  3.81287188
12  2.99515202  1.6850045  4.30529950
13  3.58282936  2.2662384  4.89942029
> 
> ##-- From  aov(.) example ---- predict(.. terms)
> npk.aov <- aov(yield ~ block + N*P*K, npk)
> (termL <- attr(terms(npk.aov), "term.labels"))
[1] "block" "N"     "P"     "K"     "N:P"   "N:K"   "P:K"   "N:P:K"
> (pt <- predict(npk.aov, type = "terms"))
    block      N          P          K        N:P    N:K        P:K N:P:K
1  -0.850 -4.925  0.2083333 -0.9583333  0.9416667  1.175  0.4250000     0
2  -0.850  4.925  0.2083333  0.9583333 -2.8250000  1.175 -0.1416667     0
3  -0.850 -4.925 -0.2083333  0.9583333  0.9416667  1.175 -0.1416667     0
4  -0.850  4.925 -0.2083333 -0.9583333  0.9416667 -3.525 -0.1416667     0
5   2.575  4.925 -0.2083333  0.9583333  0.9416667  1.175 -0.1416667     0
6   2.575  4.925  0.2083333 -0.9583333 -2.8250000 -3.525  0.4250000     0
7   2.575 -4.925 -0.2083333 -0.9583333  0.9416667  1.175 -0.1416667     0
8   2.575 -4.925  0.2083333  0.9583333  0.9416667  1.175 -0.1416667     0
9   5.900 -4.925  0.2083333  0.9583333  0.9416667  1.175 -0.1416667     0
10  5.900  4.925  0.2083333 -0.9583333 -2.8250000 -3.525  0.4250000     0
11  5.900  4.925 -0.2083333  0.9583333  0.9416667  1.175 -0.1416667     0
12  5.900 -4.925 -0.2083333 -0.9583333  0.9416667  1.175 -0.1416667     0
13 -4.750  4.925 -0.2083333  0.9583333  0.9416667  1.175 -0.1416667     0
14 -4.750  4.925  0.2083333 -0.9583333 -2.8250000 -3.525  0.4250000     0
15 -4.750 -4.925 -0.2083333 -0.9583333  0.9416667  1.175 -0.1416667     0
16 -4.750 -4.925  0.2083333  0.9583333  0.9416667  1.175 -0.1416667     0
17 -4.350  4.925  0.2083333  0.9583333 -2.8250000  1.175 -0.1416667     0
18 -4.350 -4.925 -0.2083333  0.9583333  0.9416667  1.175 -0.1416667     0
19 -4.350  4.925 -0.2083333 -0.9583333  0.9416667 -3.525 -0.1416667     0
20 -4.350 -4.925  0.2083333 -0.9583333  0.9416667  1.175  0.4250000     0
21  1.475  4.925 -0.2083333 -0.9583333  0.9416667 -3.525 -0.1416667     0
22  1.475  4.925  0.2083333  0.9583333 -2.8250000  1.175 -0.1416667     0
23  1.475 -4.925  0.2083333 -0.9583333  0.9416667  1.175  0.4250000     0
24  1.475 -4.925 -0.2083333  0.9583333  0.9416667  1.175 -0.1416667     0
attr(,"constant")
[1] 54.875
> pt. <- predict(npk.aov, type = "terms", terms = termL[1:4])
> stopifnot(all.equal(pt[,1:4], pt.,
+                     tolerance = 1e-12, check.attributes = FALSE))
> 
> 
> 
> cleanEx()
> nameEx("predict.loess")
> ### * predict.loess
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: predict.loess
> ### Title: Predict Loess Curve or Surface
> ### Aliases: predict.loess
> ### Keywords: smooth
> 
> ### ** Examples
> 
> cars.lo <- loess(dist ~ speed, cars)
> predict(cars.lo, data.frame(speed = seq(5, 30, 1)), se = TRUE)
$fit
        1         2         3         4         5         6         7         8 
 7.797353 10.002308 12.499786 15.281082 18.446568 21.865315 25.517015 29.350386 
        9        10        11        12        13        14        15        16 
33.230660 37.167935 41.205226 45.055736 48.355889 49.824812 51.986702 56.461318 
       17        18        19        20        21        22        23        24 
61.959729 68.569313 76.316068 85.212121 95.324047        NA        NA        NA 
       25        26 
       NA        NA 

$se.fit
       1        2        3        4        5        6        7        8 
7.568120 5.945831 4.990827 4.545284 4.308639 4.115049 3.789542 3.716231 
       9       10       11       12       13       14       15       16 
3.776947 4.091747 4.709568 4.245427 4.035929 3.753410 4.004705 4.043190 
      17       18       19       20       21       22       23       24 
4.026105 4.074664 4.570818 5.954217 8.302014       NA       NA       NA 
      25       26 
      NA       NA 

$residual.scale
[1] 15.29496

$df
[1] 44.6179

> # to get extrapolation
> cars.lo2 <- loess(dist ~ speed, cars,
+   control = loess.control(surface = "direct"))
> predict(cars.lo2, data.frame(speed = seq(5, 30, 1)), se = TRUE)
$fit
         1          2          3          4          5          6          7 
  7.741006   9.926596  12.442424  15.281082  18.425712  21.865315  25.713413 
         8          9         10         11         12         13         14 
 29.350386  33.230660  37.167935  41.205226  45.781544  48.355889  50.067148 
        15         16         17         18         19         20         21 
 51.986702  56.445263  62.025404  68.569313  76.193111  85.053364  95.300523 
        22         23         24         25         26 
106.974661 120.092581 134.665851 150.698545 168.190283 

$se.fit
        1         2         3         4         5         6         7         8 
 7.565991  5.959097  5.012013  4.550013  4.321596  4.119331  3.939804  3.720098 
        9        10        11        12        13        14        15        16 
 3.780877  4.096004  4.714469  4.398936  4.040129  4.184257  4.008873  4.061865 
       17        18        19        20        21        22        23        24 
 4.033998  4.078904  4.584606  5.952480  8.306901 11.601911 15.792480 20.864660 
       25        26 
26.823827 33.683999 

$residual.scale
[1] 15.31087

$df
[1] 44.55085

> 
> 
> 
> cleanEx()
> nameEx("predict.nls")
> ### * predict.nls
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: predict.nls
> ### Title: Predicting from Nonlinear Least Squares Fits
> ### Aliases: predict.nls
> ### Keywords: nonlinear regression models
> 
> ### ** Examples
> 
> ## Don't show: 
> od <- options(digits = 5)
> ## End(Don't show)
> require(graphics)
> 
> fm <- nls(demand ~ SSasympOrig(Time, A, lrc), data = BOD)
> predict(fm)              # fitted values at observed times
[1]  7.8874 12.5250 15.2517 16.8549 17.7975 18.6776
> ## Form data plot and smooth line for the predictions
> opar <- par(las = 1)
> plot(demand ~ Time, data = BOD, col = 4,
+      main = "BOD data and fitted first-order curve",
+      xlim = c(0,7), ylim = c(0, 20) )
> tt <- seq(0, 8, length.out = 101)
> lines(tt, predict(fm, list(Time = tt)))
> par(opar)
> ## Don't show: 
> options(od)
> ## End(Don't show)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("predict.smooth.spline")
> ### * predict.smooth.spline
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: predict.smooth.spline
> ### Title: Predict from Smoothing Spline Fit
> ### Aliases: predict.smooth.spline
> ### Keywords: smooth
> 
> ### ** Examples
> 
> require(graphics)
> 
> attach(cars)
> cars.spl <- smooth.spline(speed, dist, df = 6.4)
> ## Don't show: 
> print.default(cars.spl)
$x
 [1]  4  7  8  9 10 11 12 13 14 15 16 17 18 19 20 22 23 24 25

$y
 [1]  5.833836 12.575603 15.037250 17.795007 20.935898 24.228479 28.488199
 [8] 33.969567 38.578804 40.986090 43.494687 47.156344 50.862366 52.692043
[15] 54.754531 66.036824 75.010419 85.290273 95.014670

$w
 [1] 2 2 1 1 3 2 4 4 4 3 2 3 4 3 5 1 1 4 1

$yin
 [1]  6.00000 13.00000 16.00000 10.00000 26.00000 22.50000 21.50000 35.00000
 [9] 50.50000 33.33333 36.00000 40.66667 64.50000 50.00000 50.40000 66.00000
[17] 54.00000 93.75000 85.00000

$tol
[1] 7e-06

$data
$data$x
 [1]  4  4  7  7  8  9 10 10 10 11 11 12 12 12 12 13 13 13 13 14 14 14 14 15 15
[26] 15 16 16 17 17 17 18 18 18 18 19 19 19 20 20 20 20 20 22 23 24 24 24 24 25

$data$y
 [1]   2  10   4  22  16  10  18  26  34  17  28  14  20  24  28  26  34  34  46
[20]  26  36  60  80  20  26  54  32  40  32  40  50  42  56  76  84  36  46  68
[39]  32  48  52  56  64  66  54  70  92  93 120  85

$data$w
[1] 1


$no.weights
[1] TRUE

$n
[1] 50

$lev
 [1] 0.8934338 0.4379689 0.1842314 0.1529048 0.3641292 0.2022506 0.3399561
 [8] 0.3123173 0.3248036 0.2745481 0.1965797 0.2777060 0.3368286 0.2546068
[15] 0.5210306 0.1743541 0.1531692 0.6249904 0.3750748

$cv
[1] FALSE

$cv.crit
[1] 257.2678

$pen.crit
[1] 3015.936

$crit
[1] 3

$df
[1] 6.400884

$spar
[1] 0.4873957

$ratio
[1] 6.575971e-05

$lambda
[1] 0.0008526606

$iparms
 icrit  ispar   iter        errorI 
     3      0     13      0     NA 

$auxM
NULL

$fit
$knot
 [1] 0.0000000 0.0000000 0.0000000 0.0000000 0.1428571 0.1904762 0.2380952
 [8] 0.2857143 0.3333333 0.3809524 0.4285714 0.4761905 0.5238095 0.5714286
[15] 0.6190476 0.6666667 0.7142857 0.7619048 0.8571429 0.9047619 0.9523810
[22] 1.0000000 1.0000000 1.0000000 1.0000000

$nk
[1] 21

$min
[1] 4

$range
[1] 21

$coef
 [1]  5.833836  8.018090 10.929996 14.991332 17.703639 20.964154 24.055137
 [8] 28.186176 34.129352 39.113818 40.888197 43.249931 47.080201 51.367328
[15] 52.624683 54.840036 62.675393 74.718525 85.502238 91.843521 95.014670

attr(,"class")
[1] "smooth.spline.fit"

$call
smooth.spline(x = speed, y = dist, df = 6.4)

attr(,"class")
[1] "smooth.spline"
> ## End(Don't show)
> 
> ## "Proof" that the derivatives are okay, by comparing with approximation
> diff.quot <- function(x, y) {
+   ## Difference quotient (central differences where available)
+   n <- length(x); i1 <- 1:2; i2 <- (n-1):n
+   c(diff(y[i1]) / diff(x[i1]), (y[-i1] - y[-i2]) / (x[-i1] - x[-i2]),
+     diff(y[i2]) / diff(x[i2]))
+ }
> 
> xx <- unique(sort(c(seq(0, 30, by = .2), kn <- unique(speed))))
> i.kn <- match(kn, xx)   # indices of knots within xx
> op <- par(mfrow = c(2,2))
> plot(speed, dist, xlim = range(xx), main = "Smooth.spline & derivatives")
> lines(pp <- predict(cars.spl, xx), col = "red")
> points(kn, pp$y[i.kn], pch = 3, col = "dark red")
> mtext("s(x)", col = "red")
> for(d in 1:3){
+   n <- length(pp$x)
+   plot(pp$x, diff.quot(pp$x,pp$y), type = "l", xlab = "x", ylab = "",
+        col = "blue", col.main = "red",
+        main = paste0("s" ,paste(rep("'", d), collapse = ""), "(x)"))
+   mtext("Difference quotient approx.(last)", col = "blue")
+   lines(pp <- predict(cars.spl, xx, deriv = d), col = "red")
+ ## Don't show: 
+   print(pp)
+ ## End(Don't show)
+   points(kn, pp$y[i.kn], pch = 3, col = "dark red")
+   abline(h = 0, lty = 3, col = "gray")
+ }
$x
  [1]  0.0  0.2  0.4  0.6  0.8  1.0  1.2  1.4  1.6  1.8  2.0  2.2  2.4  2.6  2.8
 [16]  3.0  3.2  3.4  3.6  3.8  4.0  4.2  4.4  4.6  4.8  5.0  5.2  5.4  5.6  5.8
 [31]  6.0  6.2  6.4  6.6  6.8  7.0  7.2  7.4  7.6  7.8  8.0  8.2  8.4  8.6  8.8
 [46]  9.0  9.2  9.4  9.6  9.8 10.0 10.2 10.4 10.6 10.8 11.0 11.2 11.4 11.6 11.8
 [61] 12.0 12.2 12.4 12.6 12.8 13.0 13.2 13.4 13.6 13.8 14.0 14.2 14.4 14.6 14.8
 [76] 15.0 15.2 15.4 15.6 15.8 16.0 16.2 16.4 16.6 16.8 17.0 17.2 17.4 17.6 17.8
 [91] 18.0 18.2 18.4 18.6 18.8 19.0 19.2 19.4 19.6 19.8 20.0 20.2 20.4 20.6 20.8
[106] 21.0 21.2 21.4 21.6 21.8 22.0 22.2 22.4 22.6 22.8 23.0 23.2 23.4 23.6 23.8
[121] 24.0 24.2 24.4 24.6 24.8 25.0 25.2 25.4 25.6 25.8 26.0 26.2 26.4 26.6 26.8
[136] 27.0 27.2 27.4 27.6 27.8 28.0 28.2 28.4 28.6 28.8 29.0 29.2 29.4 29.6 29.8
[151] 30.0

$y
  [1]  2.184254  2.184254  2.184254  2.184254  2.184254  2.184254  2.184254
  [8]  2.184254  2.184254  2.184254  2.184254  2.184254  2.184254  2.184254
 [15]  2.184254  2.184254  2.184254  2.184254  2.184254  2.184254  2.184254
 [22]  2.185055  2.187545  2.191723  2.197591  2.205146  2.214391  2.225324
 [29]  2.237946  2.252257  2.268256  2.285944  2.305321  2.326387  2.349141
 [36]  2.373584  2.401852  2.436084  2.476278  2.522435  2.574554  2.635109
 [43]  2.706573  2.788944  2.882223  2.986411  3.081697  3.148275  3.186142
 [50]  3.195300  3.175749  3.166034  3.204703  3.291756  3.427192  3.611011
 [57]  3.834464  4.088800  4.374019  4.690122  5.037108  5.344118  5.540295
 [64]  5.625638  5.600147  5.463821  5.227052  4.900227  4.483347  3.976412
 [71]  3.379422  2.813354  2.399183  2.136910  2.026534  2.068056  2.203151
 [78]  2.373493  2.579082  2.819918  3.096002  3.369475  3.602482  3.795021
 [85]  3.947094  4.058699  4.080338  3.962512  3.705220  3.308463  2.772241
 [92]  2.234965  1.835047  1.572485  1.447281  1.459435  1.588383  1.813566
 [99]  2.134982  2.552632  3.066516  3.621455  4.162272  4.688967  5.201539
[106]  5.699989  6.184317  6.654523  7.110606  7.552567  7.980405  8.394132
[113]  8.793758  9.179284  9.550708  9.908031 10.197841 10.366724 10.414682
[120] 10.341713 10.147818  9.918957  9.741090  9.614215  9.538335  9.513448
[127]  9.513448  9.513448  9.513448  9.513448  9.513448  9.513448  9.513448
[134]  9.513448  9.513448  9.513448  9.513448  9.513448  9.513448  9.513448
[141]  9.513448  9.513448  9.513448  9.513448  9.513448  9.513448  9.513448
[148]  9.513448  9.513448  9.513448  9.513448

$x
  [1]  0.0  0.2  0.4  0.6  0.8  1.0  1.2  1.4  1.6  1.8  2.0  2.2  2.4  2.6  2.8
 [16]  3.0  3.2  3.4  3.6  3.8  4.0  4.2  4.4  4.6  4.8  5.0  5.2  5.4  5.6  5.8
 [31]  6.0  6.2  6.4  6.6  6.8  7.0  7.2  7.4  7.6  7.8  8.0  8.2  8.4  8.6  8.8
 [46]  9.0  9.2  9.4  9.6  9.8 10.0 10.2 10.4 10.6 10.8 11.0 11.2 11.4 11.6 11.8
 [61] 12.0 12.2 12.4 12.6 12.8 13.0 13.2 13.4 13.6 13.8 14.0 14.2 14.4 14.6 14.8
 [76] 15.0 15.2 15.4 15.6 15.8 16.0 16.2 16.4 16.6 16.8 17.0 17.2 17.4 17.6 17.8
 [91] 18.0 18.2 18.4 18.6 18.8 19.0 19.2 19.4 19.6 19.8 20.0 20.2 20.4 20.6 20.8
[106] 21.0 21.2 21.4 21.6 21.8 22.0 22.2 22.4 22.6 22.8 23.0 23.2 23.4 23.6 23.8
[121] 24.0 24.2 24.4 24.6 24.8 25.0 25.2 25.4 25.6 25.8 26.0 26.2 26.4 26.6 26.8
[136] 27.0 27.2 27.4 27.6 27.8 28.0 28.2 28.4 28.6 28.8 29.0 29.2 29.4 29.6 29.8
[151] 30.0

$y
  [1]  0.0000000000  0.0000000000  0.0000000000  0.0000000000  0.0000000000
  [6]  0.0000000000  0.0000000000  0.0000000000  0.0000000000  0.0000000000
 [11]  0.0000000000  0.0000000000  0.0000000000  0.0000000000  0.0000000000
 [16]  0.0000000000  0.0000000000  0.0000000000  0.0000000000  0.0000000000
 [21] -0.0002165147  0.0082269950  0.0166705047  0.0251140144  0.0335575241
 [26]  0.0420010338  0.0504445435  0.0588880532  0.0673315629  0.0757750726
 [31]  0.0842185822  0.0926620919  0.1011056016  0.1095491113  0.1179926210
 [36]  0.1264361307  0.1562499762  0.1860638217  0.2158776671  0.2456915126
 [41]  0.2755053581  0.3300457726  0.3845861870  0.4391266015  0.4936670160
 [46]  0.5482074305  0.4046596591  0.2611118877  0.1175641163 -0.0259836551
 [51] -0.1695314264  0.0723860374  0.3143035013  0.5562209652  0.7981384291
 [56]  1.0400558930  1.1944722898  1.3488886866  1.5033050835  1.6577214803
 [61]  1.8121378771  1.2579681380  0.7037983989  0.1496286598 -0.4045410793
 [66] -0.9587108185 -1.4089861032 -1.8592613879 -2.3095366727 -2.7598119574
 [71] -3.2100872422 -2.4505987906 -1.6911103389 -0.9316218873 -0.1721334357
 [76]  0.5873550159  0.7635912416  0.9398274674  1.1160636931  1.2922999189
 [81]  1.4685361447  1.2662005031  1.0638648615  0.8615292198  0.6591935782
 [86]  0.4568579366 -0.2404682740 -0.9377944846 -1.6351206952 -2.3324469058
 [91] -3.0297731165 -2.3429865119 -1.6561999074 -0.9694133029 -0.2826266984
 [96]  0.4041599061  0.8853283585  1.3664968109  1.8476652633  2.3288337157
[101]  2.8100021681  2.7393907024  2.6687792367  2.5981677710  2.5275563053
[106]  2.4569448396  2.3863333739  2.3157219082  2.2451104425  2.1744989768
[111]  2.1038875112  2.0333827893  1.9628780674  1.8923733455  1.8218686237
[116]  1.7513639018  1.1467332516  0.5421026014 -0.0625280487 -0.6671586989
[121] -1.2717893491 -1.0168219086 -0.7618544680 -0.5068870274 -0.2519195869
[126]  0.0030478537  0.0000000000  0.0000000000  0.0000000000  0.0000000000
[131]  0.0000000000  0.0000000000  0.0000000000  0.0000000000  0.0000000000
[136]  0.0000000000  0.0000000000  0.0000000000  0.0000000000  0.0000000000
[141]  0.0000000000  0.0000000000  0.0000000000  0.0000000000  0.0000000000
[146]  0.0000000000  0.0000000000  0.0000000000  0.0000000000  0.0000000000
[151]  0.0000000000

$x
  [1]  0.0  0.2  0.4  0.6  0.8  1.0  1.2  1.4  1.6  1.8  2.0  2.2  2.4  2.6  2.8
 [16]  3.0  3.2  3.4  3.6  3.8  4.0  4.2  4.4  4.6  4.8  5.0  5.2  5.4  5.6  5.8
 [31]  6.0  6.2  6.4  6.6  6.8  7.0  7.2  7.4  7.6  7.8  8.0  8.2  8.4  8.6  8.8
 [46]  9.0  9.2  9.4  9.6  9.8 10.0 10.2 10.4 10.6 10.8 11.0 11.2 11.4 11.6 11.8
 [61] 12.0 12.2 12.4 12.6 12.8 13.0 13.2 13.4 13.6 13.8 14.0 14.2 14.4 14.6 14.8
 [76] 15.0 15.2 15.4 15.6 15.8 16.0 16.2 16.4 16.6 16.8 17.0 17.2 17.4 17.6 17.8
 [91] 18.0 18.2 18.4 18.6 18.8 19.0 19.2 19.4 19.6 19.8 20.0 20.2 20.4 20.6 20.8
[106] 21.0 21.2 21.4 21.6 21.8 22.0 22.2 22.4 22.6 22.8 23.0 23.2 23.4 23.6 23.8
[121] 24.0 24.2 24.4 24.6 24.8 25.0 25.2 25.4 25.6 25.8 26.0 26.2 26.4 26.6 26.8
[136] 27.0 27.2 27.4 27.6 27.8 28.0 28.2 28.4 28.6 28.8 29.0 29.2 29.4 29.6 29.8
[151] 30.0

$y
  [1]  0.00000000  0.00000000  0.00000000  0.00000000  0.00000000  0.00000000
  [7]  0.00000000  0.00000000  0.00000000  0.00000000  0.00000000  0.00000000
 [13]  0.00000000  0.00000000  0.00000000  0.00000000  0.00000000  0.00000000
 [19]  0.00000000  0.00000000  0.04221755  0.04221755  0.04221755  0.04221755
 [25]  0.04221755  0.04221755  0.04221755  0.04221755  0.04221755  0.04221755
 [31]  0.04221755  0.04221755  0.04221755  0.04221755  0.04221755  0.14906923
 [37]  0.14906923  0.14906923  0.14906923  0.14906923  0.27270207  0.27270207
 [43]  0.27270207  0.27270207  0.27270207 -0.71773886 -0.71773886 -0.71773886
 [49] -0.71773886 -0.71773886  1.20958732  1.20958732  1.20958732  1.20958732
 [55]  1.20958732  0.77208198  0.77208198  0.77208198  0.77208198  0.77208198
 [61] -2.77084870 -2.77084870 -2.77084870 -2.77084870 -2.77084870 -2.25137642
 [67] -2.25137642 -2.25137642 -2.25137642 -2.25137642  3.79744226  3.79744226
 [73]  3.79744226  3.79744226  3.79744226  0.88118113  0.88118113  0.88118113
 [79]  0.88118113  0.88118113 -1.01167821 -1.01167821 -1.01167821 -1.01167821
 [85] -1.01167821 -3.48663105 -3.48663105 -3.48663105 -3.48663105 -3.48663105
 [91]  3.43393302  3.43393302  3.43393302  3.43393302  3.43393302  2.40584226
 [97]  2.40584226  2.40584226  2.40584226  2.40584226 -0.35305733 -0.35305733
[103] -0.35305733 -0.35305733 -0.35305733 -0.35305733 -0.35305733 -0.35305733
[109] -0.35305733 -0.35305733 -0.35252361 -0.35252361 -0.35252361 -0.35252361
[115] -0.35252361 -3.02315325 -3.02315325 -3.02315325 -3.02315325 -3.02315325
[121]  1.27483720  1.27483720  1.27483720  1.27483720  1.27483720  1.27483720
[127]  0.00000000  0.00000000  0.00000000  0.00000000  0.00000000  0.00000000
[133]  0.00000000  0.00000000  0.00000000  0.00000000  0.00000000  0.00000000
[139]  0.00000000  0.00000000  0.00000000  0.00000000  0.00000000  0.00000000
[145]  0.00000000  0.00000000  0.00000000  0.00000000  0.00000000  0.00000000
[151]  0.00000000

> detach(); par(op)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("princomp")
> ### * princomp
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: princomp
> ### Title: Principal Components Analysis
> ### Aliases: princomp princomp.formula princomp.default plot.princomp
> ###   print.princomp predict.princomp
> ### Keywords: multivariate
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## The variances of the variables in the
> ## USArrests data vary by orders of magnitude, so scaling is appropriate
> (pc.cr <- princomp(USArrests))  # inappropriate
Call:
princomp(x = USArrests)

Standard deviations:
   Comp.1    Comp.2    Comp.3    Comp.4 
82.890847 14.069560  6.424204  2.457837 

 4  variables and  50 observations.
> princomp(USArrests, cor = TRUE) # =^= prcomp(USArrests, scale=TRUE)
Call:
princomp(x = USArrests, cor = TRUE)

Standard deviations:
   Comp.1    Comp.2    Comp.3    Comp.4 
1.5748783 0.9948694 0.5971291 0.4164494 

 4  variables and  50 observations.
> ## Similar, but different:
> ## The standard deviations differ by a factor of sqrt(49/50)
> 
> summary(pc.cr <- princomp(USArrests, cor = TRUE))
Importance of components:
                          Comp.1    Comp.2    Comp.3     Comp.4
Standard deviation     1.5748783 0.9948694 0.5971291 0.41644938
Proportion of Variance 0.6200604 0.2474413 0.0891408 0.04335752
Cumulative Proportion  0.6200604 0.8675017 0.9566425 1.00000000
> loadings(pc.cr)  # note that blank entries are small but not zero

Loadings:
         Comp.1 Comp.2 Comp.3 Comp.4
Murder    0.536  0.418  0.341  0.649
Assault   0.583  0.188  0.268 -0.743
UrbanPop  0.278 -0.873  0.378  0.134
Rape      0.543 -0.167 -0.818       

               Comp.1 Comp.2 Comp.3 Comp.4
SS loadings      1.00   1.00   1.00   1.00
Proportion Var   0.25   0.25   0.25   0.25
Cumulative Var   0.25   0.50   0.75   1.00
> ## The signs of the columns of the loadings are arbitrary
> plot(pc.cr) # shows a screeplot.
> biplot(pc.cr)
> 
> ## Formula interface
> princomp(~ ., data = USArrests, cor = TRUE)
Call:
princomp(formula = ~., data = USArrests, cor = TRUE)

Standard deviations:
   Comp.1    Comp.2    Comp.3    Comp.4 
1.5748783 0.9948694 0.5971291 0.4164494 

 4  variables and  50 observations.
> 
> ## NA-handling
> USArrests[1, 2] <- NA
> pc.cr <- princomp(~ Murder + Assault + UrbanPop,
+                   data = USArrests, na.action = na.exclude, cor = TRUE)
> 
> ## (Simple) Robust PCA:
> ## Classical:
> (pc.cl  <- princomp(stackloss))
Call:
princomp(x = stackloss)

Standard deviations:
   Comp.1    Comp.2    Comp.3    Comp.4 
13.596589  4.676077  2.617533  1.366320 

 4  variables and  21 observations.
> 
> 
> cleanEx()
> nameEx("print.power.htest")
> ### * print.power.htest
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: print.power.htest
> ### Title: Print Methods for Hypothesis Tests and Power Calculation Objects
> ### Aliases: print.htest print.power.htest
> ### Keywords: htest
> 
> ### ** Examples
> 
> (ptt <- power.t.test(n = 20, delta = 1))

     Two-sample t test power calculation 

              n = 20
          delta = 1
             sd = 1
      sig.level = 0.05
          power = 0.8689528
    alternative = two.sided

NOTE: n is number in *each* group

> print(ptt, digits =  4) # using less digits than default

     Two-sample t test power calculation 

              n = 20
          delta = 1
             sd = 1
      sig.level = 0.05
          power = 0.869
    alternative = two.sided

NOTE: n is number in *each* group

> print(ptt, digits = 12) # using more  "       "     "

     Two-sample t test power calculation 

              n = 20
          delta = 1
             sd = 1
      sig.level = 0.05
          power = 0.868952801692
    alternative = two.sided

NOTE: n is number in *each* group

> 
> 
> 
> cleanEx()
> nameEx("print.ts")
> ### * print.ts
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: print.ts
> ### Title: Printing and Formatting of Time-Series Objects
> ### Aliases: .preformat.ts print.ts
> ### Keywords: ts
> 
> ### ** Examples
> 
> print(ts(1:10, frequency = 7, start = c(12, 2)), calendar = TRUE)
   p1 p2 p3 p4 p5 p6 p7
12     1  2  3  4  5  6
13  7  8  9 10         
> 
> print(sunsp.1 <- window(sunspot.month, end=c(1756, 12)))
       Jan   Feb   Mar   Apr   May   Jun   Jul   Aug   Sep   Oct   Nov   Dec
1749  58.0  62.6  70.0  55.7  85.0  83.5  94.8  66.3  75.9  75.5 158.6  85.2
1750  73.3  75.9  89.2  88.3  90.0 100.0  85.4 103.0  91.2  65.7  63.3  75.4
1751  70.0  43.5  45.3  56.4  60.7  50.7  66.3  59.8  23.5  23.2  28.5  44.0
1752  35.0  50.0  71.0  59.3  59.7  39.6  78.4  29.3  27.1  46.6  37.6  40.0
1753  44.0  32.0  45.7  38.0  36.0  31.7  22.0  39.0  28.0  25.0  20.0   6.7
1754   0.0   3.0   1.7  13.7  20.7  26.7  18.8  12.3   8.2  24.1  13.2   4.2
1755  10.2  11.2   6.8   6.5   0.0   0.0   8.6   3.2  17.8  23.7   6.8  20.0
1756  12.5   7.1   5.4   9.4  12.5  12.9   3.6   6.4  11.8  14.3  17.0   9.4
> m <- .preformat.ts(sunsp.1) # a character matrix
> 
> 
> 
> cleanEx()
> nameEx("printCoefmat")
> ### * printCoefmat
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: printCoefmat
> ### Title: Print Coefficient Matrices
> ### Aliases: printCoefmat
> ### Keywords: print
> 
> ### ** Examples
> 
> cmat <- cbind(rnorm(3, 10), sqrt(rchisq(3, 12)))
> cmat <- cbind(cmat, cmat[, 1]/cmat[, 2])
> cmat <- cbind(cmat, 2*pnorm(-cmat[, 3]))
> colnames(cmat) <- c("Estimate", "Std.Err", "Z value", "Pr(>z)")
> printCoefmat(cmat[, 1:3])
     Estimate Std.Err Z value
[1,]   9.3735  4.4447  2.1089
[2,]  10.1836  3.5496  2.8689
[3,]   9.1644  2.7365  3.3490
> printCoefmat(cmat)
     Estimate Std.Err Z value    Pr(>z)    
[1,]   9.3735  4.4447  2.1089 0.0349492 *  
[2,]  10.1836  3.5496  2.8689 0.0041185 ** 
[3,]   9.1644  2.7365  3.3490 0.0008111 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
> op <- options(show.coef.Pvalues = FALSE)
> printCoefmat(cmat, digits = 2)
     Estimate Std.Err Z value
[1,]      9.4     4.4     2.1
[2,]     10.2     3.5     2.9
[3,]      9.2     2.7     3.3
> printCoefmat(cmat, digits = 2, P.values = TRUE)
     Estimate Std.Err Z value Pr(>z)    
[1,]      9.4     4.4     2.1  0.035 *  
[2,]     10.2     3.5     2.9  0.004 ** 
[3,]      9.2     2.7     3.3  8e-04 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
> options(op) # restore
> 
> 
> 
> cleanEx()
> nameEx("profile.nls")
> ### * profile.nls
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: profile.nls
> ### Title: Method for Profiling nls Objects
> ### Aliases: profile.nls
> ### Keywords: nonlinear regression models
> 
> ### ** Examples
> 
> ## Don't show: 
> od <- options(digits = 4)
> ## End(Don't show)
> # obtain the fitted object
> fm1 <- nls(demand ~ SSasympOrig(Time, A, lrc), data = BOD)
> # get the profile for the fitted model: default level is too extreme
> pr1 <- profile(fm1, alphamax = 0.05)
> # profiled values for the two parameters
> ## IGNORE_RDIFF_BEGIN
> pr1$A
       tau par.vals.A par.vals.lrc
1  -3.0873   13.59751      0.14033
2  -2.4957   14.46884      0.01607
3  -1.8906   15.41836     -0.11787
4  -1.2634   16.49088     -0.26877
5  -0.6080   17.75662     -0.44553
6   0.0000   19.14258     -0.63282
7   0.4998   20.52853     -0.80750
8   0.9465   22.06851     -0.98233
9   1.3780   23.98253     -1.17103
10  1.7908   26.44552     -1.37431
11  2.1841   29.75928     -1.59599
12  2.5559   34.43804     -1.84209
13  2.9028   41.42542     -2.12176
> pr1$lrc
       tau par.vals.A par.vals.lrc
1  -2.9550  42.395076    -2.184153
2  -2.5201  33.446683    -1.836926
3  -2.0570  28.124205    -1.547326
4  -1.5710  24.656989    -1.293871
5  -1.0653  22.245847    -1.063030
6  -0.5412  20.482887    -0.845157
7   0.0000  19.142578    -0.632822
8   0.5539  18.095015    -0.420487
9   1.1022  17.273414    -0.207623
10  1.6298  16.621533     0.007939
11  2.1335  16.086803     0.234850
12  2.6052  15.638807     0.485009
13  3.0276  15.265409     0.779458
> ## IGNORE_RDIFF_END
> # see also example(plot.profile.nls)
> ## Don't show: 
> options(od)
> ## End(Don't show)
> 
> 
> 
> cleanEx()
> nameEx("proj")
> ### * proj
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: proj
> ### Title: Projections of Models
> ### Aliases: proj proj.default proj.lm proj.aov proj.aovlist
> ### Keywords: models
> 
> ### ** Examples
> 
> N <- c(0,1,0,1,1,1,0,0,0,1,1,0,1,1,0,0,1,0,1,0,1,1,0,0)
> P <- c(1,1,0,0,0,1,0,1,1,1,0,0,0,1,0,1,1,0,0,1,0,1,1,0)
> K <- c(1,0,0,1,0,1,1,0,0,1,0,1,0,1,1,0,0,0,1,1,1,0,1,0)
> yield <- c(49.5,62.8,46.8,57.0,59.8,58.5,55.5,56.0,62.8,55.8,69.5,
+ 55.0, 62.0,48.8,45.5,44.2,52.0,51.5,49.8,48.8,57.2,59.0,53.2,56.0)
> 
> npk <- data.frame(block = gl(6,4), N = factor(N), P = factor(P),
+                   K = factor(K), yield = yield)
> npk.aov <- aov(yield ~ block + N*P*K, npk)
> proj(npk.aov)
   (Intercept)  block         N          P         K        N:P    N:K
1       54.875 -0.850 -2.808333 -0.5916667 -1.991667  0.9416667  1.175
2       54.875 -0.850  2.808333 -0.5916667  1.991667 -0.9416667  1.175
3       54.875 -0.850 -2.808333  0.5916667  1.991667 -0.9416667 -1.175
4       54.875 -0.850  2.808333  0.5916667 -1.991667  0.9416667 -1.175
5       54.875  2.575  2.808333  0.5916667  1.991667  0.9416667  1.175
6       54.875  2.575  2.808333 -0.5916667 -1.991667 -0.9416667 -1.175
7       54.875  2.575 -2.808333  0.5916667 -1.991667 -0.9416667  1.175
8       54.875  2.575 -2.808333 -0.5916667  1.991667  0.9416667 -1.175
9       54.875  5.900 -2.808333 -0.5916667  1.991667  0.9416667 -1.175
10      54.875  5.900  2.808333 -0.5916667 -1.991667 -0.9416667 -1.175
11      54.875  5.900  2.808333  0.5916667  1.991667  0.9416667  1.175
12      54.875  5.900 -2.808333  0.5916667 -1.991667 -0.9416667  1.175
13      54.875 -4.750  2.808333  0.5916667  1.991667  0.9416667  1.175
14      54.875 -4.750  2.808333 -0.5916667 -1.991667 -0.9416667 -1.175
15      54.875 -4.750 -2.808333  0.5916667 -1.991667 -0.9416667  1.175
16      54.875 -4.750 -2.808333 -0.5916667  1.991667  0.9416667 -1.175
17      54.875 -4.350  2.808333 -0.5916667  1.991667 -0.9416667  1.175
18      54.875 -4.350 -2.808333  0.5916667  1.991667 -0.9416667 -1.175
19      54.875 -4.350  2.808333  0.5916667 -1.991667  0.9416667 -1.175
20      54.875 -4.350 -2.808333 -0.5916667 -1.991667  0.9416667  1.175
21      54.875  1.475  2.808333  0.5916667 -1.991667  0.9416667 -1.175
22      54.875  1.475  2.808333 -0.5916667  1.991667 -0.9416667  1.175
23      54.875  1.475 -2.808333 -0.5916667 -1.991667  0.9416667  1.175
24      54.875  1.475 -2.808333  0.5916667  1.991667 -0.9416667 -1.175
          P:K   Residuals
1   0.1416667 -1.39166667
2  -0.1416667  4.47500000
3   0.1416667 -5.02500000
4  -0.1416667  1.94166667
5   0.1416667 -5.30000000
6   0.1416667  2.80000000
7  -0.1416667  2.16666667
8  -0.1416667  0.33333333
9  -0.1416667  3.80833333
10  0.1416667 -3.22500000
11  0.1416667  1.07500000
12 -0.1416667 -1.65833333
13  0.1416667  4.22500000
14  0.1416667  0.42500000
15 -0.1416667 -0.50833333
16 -0.1416667 -4.14166667
17 -0.1416667 -2.82500000
18  0.1416667  3.17500000
19 -0.1416667 -1.75833333
20  0.1416667  1.40833333
21 -0.1416667 -0.18333333
22 -0.1416667 -1.65000000
23  0.1416667 -0.01666667
24  0.1416667  1.85000000
attr(,"df")
(Intercept)       block           N           P           K         N:P 
          1           5           1           1           1           1 
        N:K         P:K   Residuals 
          1           1          12 
attr(,"formula")
yield ~ block + N * P * K
attr(,"onedf")
[1] FALSE
attr(,"factors")
attr(,"factors")$`(Intercept)`
[1] "(Intercept)"

attr(,"factors")$block
[1] "block"

attr(,"factors")$N
[1] "N"

attr(,"factors")$P
[1] "P"

attr(,"factors")$K
[1] "K"

attr(,"factors")$`N:P`
[1] "N" "P"

attr(,"factors")$`N:K`
[1] "N" "K"

attr(,"factors")$`P:K`
[1] "P" "K"

attr(,"factors")$Residuals
[1] "block"  "N"      "P"      "K"      "Within"

attr(,"call")
aov(formula = yield ~ block + N * P * K, data = npk)
attr(,"t.factor")
      block N P K N:P N:K P:K N:P:K
yield     0 0 0 0   0   0   0     0
block     1 0 0 0   0   0   0     0
N         0 1 0 0   1   1   0     1
P         0 0 1 0   1   0   1     1
K         0 0 0 1   0   1   1     1
attr(,"class")
[1] "aovproj"
> 
> ## as a test, not particularly sensible
> options(contrasts = c("contr.helmert", "contr.treatment"))
> npk.aovE <- aov(yield ~  N*P*K + Error(block), npk)
> proj(npk.aovE)
(Intercept) :
   (Intercept)
1       54.875
2       54.875
3       54.875
4       54.875
5       54.875
6       54.875
7       54.875
8       54.875
9       54.875
10      54.875
11      54.875
12      54.875
13      54.875
14      54.875
15      54.875
16      54.875
17      54.875
18      54.875
19      54.875
20      54.875
21      54.875
22      54.875
23      54.875
24      54.875
attr(,"df")
attr(,"df")$df
(Intercept) 
          1 

attr(,"onedf")
attr(,"onedf")$onedf
[1] FALSE

attr(,"factors")
attr(,"factors")$`(Intercept)`
[1] "(Intercept)"


block :
       N:P:K  Residuals
1  -1.241667  0.3916667
2  -1.241667  0.3916667
3  -1.241667  0.3916667
4  -1.241667  0.3916667
5   1.241667  1.3333333
6   1.241667  1.3333333
7   1.241667  1.3333333
8   1.241667  1.3333333
9   1.241667  4.6583333
10  1.241667  4.6583333
11  1.241667  4.6583333
12  1.241667  4.6583333
13  1.241667 -5.9916667
14  1.241667 -5.9916667
15  1.241667 -5.9916667
16  1.241667 -5.9916667
17 -1.241667 -3.1083333
18 -1.241667 -3.1083333
19 -1.241667 -3.1083333
20 -1.241667 -3.1083333
21 -1.241667  2.7166667
22 -1.241667  2.7166667
23 -1.241667  2.7166667
24 -1.241667  2.7166667
attr(,"df")
attr(,"df")$df
    N:P:K Residuals 
        1         4 

attr(,"onedf")
attr(,"onedf")$onedf
[1] FALSE

attr(,"factors")
attr(,"factors")$`N:P:K`
[1] "N" "P" "K"

attr(,"factors")$Residuals
[1] "block"


Within :
           N          P         K        N:P    N:K        P:K   Residuals
1  -2.808333 -0.5916667 -1.991667  0.9416667  1.175  0.1416667 -1.39166667
2   2.808333 -0.5916667  1.991667 -0.9416667  1.175 -0.1416667  4.47500000
3  -2.808333  0.5916667  1.991667 -0.9416667 -1.175  0.1416667 -5.02500000
4   2.808333  0.5916667 -1.991667  0.9416667 -1.175 -0.1416667  1.94166667
5   2.808333  0.5916667  1.991667  0.9416667  1.175  0.1416667 -5.30000000
6   2.808333 -0.5916667 -1.991667 -0.9416667 -1.175  0.1416667  2.80000000
7  -2.808333  0.5916667 -1.991667 -0.9416667  1.175 -0.1416667  2.16666667
8  -2.808333 -0.5916667  1.991667  0.9416667 -1.175 -0.1416667  0.33333333
9  -2.808333 -0.5916667  1.991667  0.9416667 -1.175 -0.1416667  3.80833333
10  2.808333 -0.5916667 -1.991667 -0.9416667 -1.175  0.1416667 -3.22500000
11  2.808333  0.5916667  1.991667  0.9416667  1.175  0.1416667  1.07500000
12 -2.808333  0.5916667 -1.991667 -0.9416667  1.175 -0.1416667 -1.65833333
13  2.808333  0.5916667  1.991667  0.9416667  1.175  0.1416667  4.22500000
14  2.808333 -0.5916667 -1.991667 -0.9416667 -1.175  0.1416667  0.42500000
15 -2.808333  0.5916667 -1.991667 -0.9416667  1.175 -0.1416667 -0.50833333
16 -2.808333 -0.5916667  1.991667  0.9416667 -1.175 -0.1416667 -4.14166667
17  2.808333 -0.5916667  1.991667 -0.9416667  1.175 -0.1416667 -2.82500000
18 -2.808333  0.5916667  1.991667 -0.9416667 -1.175  0.1416667  3.17500000
19  2.808333  0.5916667 -1.991667  0.9416667 -1.175 -0.1416667 -1.75833333
20 -2.808333 -0.5916667 -1.991667  0.9416667  1.175  0.1416667  1.40833333
21  2.808333  0.5916667 -1.991667  0.9416667 -1.175 -0.1416667 -0.18333333
22  2.808333 -0.5916667  1.991667 -0.9416667  1.175 -0.1416667 -1.65000000
23 -2.808333 -0.5916667 -1.991667  0.9416667  1.175  0.1416667 -0.01666667
24 -2.808333  0.5916667  1.991667 -0.9416667 -1.175  0.1416667  1.85000000
attr(,"df")
attr(,"df")$df
        N         P         K       N:P       N:K       P:K Residuals 
        1         1         1         1         1         1        12 

attr(,"onedf")
attr(,"onedf")$onedf
[1] FALSE

attr(,"factors")
attr(,"factors")$N
[1] "N"

attr(,"factors")$P
[1] "P"

attr(,"factors")$K
[1] "K"

attr(,"factors")$`N:P`
[1] "N" "P"

attr(,"factors")$`N:K`
[1] "N" "K"

attr(,"factors")$`P:K`
[1] "P" "K"

attr(,"factors")$Residuals
[1] "block"  "Within"


> 
> 
> 
> base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
> cleanEx()
> nameEx("prop.test")
> ### * prop.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: prop.test
> ### Title: Test of Equal or Given Proportions
> ### Aliases: prop.test
> ### Keywords: htest
> 
> ### ** Examples
> 
> heads <- rbinom(1, size = 100, prob = .5)
> prop.test(heads, 100)          # continuity correction TRUE by default

	1-sample proportions test with continuity correction

data:  heads out of 100, null probability 0.5
X-squared = 0.09, df = 1, p-value = 0.7642
alternative hypothesis: true p is not equal to 0.5
95 percent confidence interval:
 0.4183183 0.6201278
sample estimates:
   p 
0.52 

> prop.test(heads, 100, correct = FALSE)

	1-sample proportions test without continuity correction

data:  heads out of 100, null probability 0.5
X-squared = 0.16, df = 1, p-value = 0.6892
alternative hypothesis: true p is not equal to 0.5
95 percent confidence interval:
 0.4231658 0.6153545
sample estimates:
   p 
0.52 

> 
> ## Data from Fleiss (1981), p. 139.
> ## H0: The null hypothesis is that the four populations from which
> ##     the patients were drawn have the same true proportion of smokers.
> ## A:  The alternative is that this proportion is different in at
> ##     least one of the populations.
> 
> smokers  <- c( 83, 90, 129, 70 )
> patients <- c( 86, 93, 136, 82 )
> prop.test(smokers, patients)

	4-sample test for equality of proportions without continuity correction

data:  smokers out of patients
X-squared = 12.6, df = 3, p-value = 0.005585
alternative hypothesis: two.sided
sample estimates:
   prop 1    prop 2    prop 3    prop 4 
0.9651163 0.9677419 0.9485294 0.8536585 

> 
> 
> 
> cleanEx()
> nameEx("prop.trend.test")
> ### * prop.trend.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: prop.trend.test
> ### Title: Test for trend in proportions
> ### Aliases: prop.trend.test
> ### Keywords: htest
> 
> ### ** Examples
> 
> smokers  <- c( 83, 90, 129, 70 )
> patients <- c( 86, 93, 136, 82 )
> prop.test(smokers, patients)

	4-sample test for equality of proportions without continuity correction

data:  smokers out of patients
X-squared = 12.6, df = 3, p-value = 0.005585
alternative hypothesis: two.sided
sample estimates:
   prop 1    prop 2    prop 3    prop 4 
0.9651163 0.9677419 0.9485294 0.8536585 

> prop.trend.test(smokers, patients)

	Chi-squared Test for Trend in Proportions

data:  smokers out of patients ,
 using scores: 1 2 3 4
X-squared = 8.2249, df = 1, p-value = 0.004132

> prop.trend.test(smokers, patients, c(0,0,0,1))

	Chi-squared Test for Trend in Proportions

data:  smokers out of patients ,
 using scores: 0 0 0 1
X-squared = 12.173, df = 1, p-value = 0.0004848

> 
> 
> 
> cleanEx()
> nameEx("qqnorm")
> ### * qqnorm
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: qqnorm
> ### Title: Quantile-Quantile Plots
> ### Aliases: qqnorm qqnorm.default qqplot qqline
> ### Keywords: hplot distribution
> 
> ### ** Examples
> 
> require(graphics)
> 
> y <- rt(200, df = 5)
> qqnorm(y); qqline(y, col = 2)
> qqplot(y, rt(300, df = 5))
> 
> qqnorm(precip, ylab = "Precipitation [in/yr] for 70 US cities")
> 
> ## "QQ-Chisquare" : --------------------------
> y <- rchisq(500, df = 3)
> ## Q-Q plot for Chi^2 data against true theoretical distribution:
> qqplot(qchisq(ppoints(500), df = 3), y,
+        main = expression("Q-Q plot for" ~~ {chi^2}[nu == 3]))
> qqline(y, distribution = function(p) qchisq(p, df = 3),
+        probs = c(0.1, 0.6), col = 2)
> mtext("qqline(*, dist = qchisq(., df=3), prob = c(0.1, 0.6))")
> ## (Note that the above uses ppoints() with a = 1/2, giving the
> ## probability points for quantile type 5: so theoretically, using
> ## qqline(qtype = 5) might be preferable.) 
> 
> 
> 
> cleanEx()
> nameEx("quade.test")
> ### * quade.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: quade.test
> ### Title: Quade Test
> ### Aliases: quade.test quade.test.default quade.test.formula
> ### Keywords: htest
> 
> ### ** Examples
> 
> ## Conover (1999, p. 375f):
> ## Numbers of five brands of a new hand lotion sold in seven stores
> ## during one week.
> y <- matrix(c( 5,  4,  7, 10, 12,
+                1,  3,  1,  0,  2,
+               16, 12, 22, 22, 35,
+                5,  4,  3,  5,  4,
+               10,  9,  7, 13, 10,
+               19, 18, 28, 37, 58,
+               10,  7,  6,  8,  7),
+             nrow = 7, byrow = TRUE,
+             dimnames =
+             list(Store = as.character(1:7),
+                  Brand = LETTERS[1:5]))
> y
     Brand
Store  A  B  C  D  E
    1  5  4  7 10 12
    2  1  3  1  0  2
    3 16 12 22 22 35
    4  5  4  3  5  4
    5 10  9  7 13 10
    6 19 18 28 37 58
    7 10  7  6  8  7
> (qTst <- quade.test(y))

	Quade test

data:  y
Quade F = 3.8293, num df = 4, denom df = 24, p-value = 0.01519

> 
> ## Show equivalence of different versions of test :
> utils::str(dy <- as.data.frame(as.table(y)))
'data.frame':	35 obs. of  3 variables:
 $ Store: Factor w/ 7 levels "1","2","3","4",..: 1 2 3 4 5 6 7 1 2 3 ...
 $ Brand: Factor w/ 5 levels "A","B","C","D",..: 1 1 1 1 1 1 1 2 2 2 ...
 $ Freq : num  5 1 16 5 10 19 10 4 3 12 ...
> qT. <- quade.test(Freq ~ Brand|Store, data = dy)
> qT.$data.name <- qTst$data.name
> stopifnot(all.equal(qTst, qT., tolerance = 1e-15))
> dys <- dy[order(dy[,"Freq"]),]
> qTs <- quade.test(Freq ~ Brand|Store, data = dys)
> qTs$data.name <- qTst$data.name
> stopifnot(all.equal(qTst, qTs, tolerance = 1e-15))
> 
> 
> 
> cleanEx()
> nameEx("quantile")
> ### * quantile
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: quantile
> ### Title: Sample Quantiles
> ### Aliases: quantile quantile.default
> ### Keywords: univar
> 
> ### ** Examples
> 
> quantile(x <- rnorm(1001)) # Extremes & Quartiles by default
         0%         25%         50%         75%        100% 
-3.00804860 -0.69731820 -0.03472603  0.68924373  3.81027668 
> quantile(x,  probs = c(0.1, 0.5, 1, 2, 5, 10, 50, NA)/100)
       0.1%        0.5%          1%          2%          5%         10% 
-2.99694930 -2.59232767 -2.42431731 -2.24515257 -1.72663060 -1.33880074 
        50%             
-0.03472603          NA 
> 
> ### Compare different types
> quantAll <- function(x, prob, ...)
+   t(vapply(1:9, function(typ) quantile(x, probs = prob, type = typ, ...),
+            quantile(x, prob, type=1, ...)))
> p <- c(0.1, 0.5, 1, 2, 5, 10, 50)/100
> signif(quantAll(x, p), 4)
        0.1%   0.5%     1%     2%     5%    10%      50%
 [1,] -2.997 -2.592 -2.424 -2.245 -1.727 -1.339 -0.03473
 [2,] -2.997 -2.592 -2.424 -2.245 -1.727 -1.339 -0.03473
 [3,] -3.008 -2.596 -2.433 -2.265 -1.733 -1.344 -0.03592
 [4,] -3.008 -2.596 -2.433 -2.264 -1.733 -1.344 -0.03532
 [5,] -3.002 -2.594 -2.428 -2.255 -1.730 -1.341 -0.03473
 [6,] -3.008 -2.596 -2.432 -2.264 -1.733 -1.343 -0.03473
 [7,] -2.997 -2.592 -2.424 -2.245 -1.727 -1.339 -0.03473
 [8,] -3.004 -2.595 -2.430 -2.258 -1.731 -1.342 -0.03473
 [9,] -3.004 -2.595 -2.429 -2.257 -1.730 -1.341 -0.03473
> 
> ## 0% and 100% are equal to min(), max() for all types:
> stopifnot(t(quantAll(x, prob=0:1)) == range(x))
> 
> ## for complex numbers:
> z <- complex(real = x, imaginary = -10*x)
> signif(quantAll(z, p), 4)
              0.1%         0.5%           1%           2%           5%
 [1,] -3.00+29.97i -2.59+25.92i -2.42+24.24i -2.25+22.45i -1.73+17.27i
 [2,] -3.00+29.97i -2.59+25.92i -2.42+24.24i -2.25+22.45i -1.73+17.27i
 [3,] -3.01+30.08i -2.60+25.96i -2.43+24.33i -2.26+22.65i -1.73+17.33i
 [4,] -3.01+30.08i -2.60+25.96i -2.43+24.33i -2.26+22.64i -1.73+17.33i
 [5,] -3.00+30.02i -2.59+25.94i -2.43+24.28i -2.25+22.55i -1.73+17.30i
 [6,] -3.01+30.08i -2.60+25.96i -2.43+24.32i -2.26+22.64i -1.73+17.33i
 [7,] -3.00+29.97i -2.59+25.92i -2.42+24.24i -2.25+22.45i -1.73+17.27i
 [8,] -3.00+30.04i -2.59+25.95i -2.43+24.30i -2.26+22.58i -1.73+17.31i
 [9,] -3.00+30.04i -2.59+25.95i -2.43+24.29i -2.26+22.57i -1.73+17.30i
               10%             50%
 [1,] -1.34+13.39i -0.0347+0.3473i
 [2,] -1.34+13.39i -0.0347+0.3473i
 [3,] -1.34+13.44i -0.0359+0.3592i
 [4,] -1.34+13.44i -0.0353+0.3532i
 [5,] -1.34+13.41i -0.0347+0.3473i
 [6,] -1.34+13.43i -0.0347+0.3473i
 [7,] -1.34+13.39i -0.0347+0.3473i
 [8,] -1.34+13.42i -0.0347+0.3473i
 [9,] -1.34+13.41i -0.0347+0.3473i
> 
> 
> 
> cleanEx()
> nameEx("r2dtable")
> ### * r2dtable
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: r2dtable
> ### Title: Random 2-way Tables with Given Marginals
> ### Aliases: r2dtable
> ### Keywords: distribution
> 
> ### ** Examples
> 
> ## Fisher's Tea Drinker data.
> TeaTasting <-
+ matrix(c(3, 1, 1, 3),
+        nrow = 2,
+        dimnames = list(Guess = c("Milk", "Tea"),
+                        Truth = c("Milk", "Tea")))
> ## Simulate permutation test for independence based on the maximum
> ## Pearson residuals (rather than their sum).
> rowTotals <- rowSums(TeaTasting)
> colTotals <- colSums(TeaTasting)
> nOfCases <- sum(rowTotals)
> expected <- outer(rowTotals, colTotals) / nOfCases
> maxSqResid <- function(x) max((x - expected) ^ 2 / expected)
> simMaxSqResid <-
+     sapply(r2dtable(1000, rowTotals, colTotals), maxSqResid)
> sum(simMaxSqResid >= maxSqResid(TeaTasting)) / 1000
[1] 0.465
> ## Fisher's exact test gives p = 0.4857 ...
> 
> 
> 
> cleanEx()
> nameEx("rWishart")
> ### * rWishart
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: rWishart
> ### Title: Random Wishart Distributed Matrices
> ### Aliases: rWishart
> ### Keywords: multivariate
> 
> ### ** Examples
> 
> ## Artificial
> S <- toeplitz((10:1)/10)
> set.seed(11)
> R <- rWishart(1000, 20, S)
> dim(R)  #  10 10  1000
[1]   10   10 1000
> mR <- apply(R, 1:2, mean)  # ~= E[ Wish(S, 20) ] = 20 * S
> stopifnot(all.equal(mR, 20*S, tolerance = .009))
> 
> ## See Details, the variance is
> Va <- 20*(S^2 + tcrossprod(diag(S)))
> vR <- apply(R, 1:2, var)
> stopifnot(all.equal(vR, Va, tolerance = 1/16))
> 
> 
> 
> cleanEx()
> nameEx("read.ftable")
> ### * read.ftable
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: read.ftable
> ### Title: Manipulate Flat Contingency Tables
> ### Aliases: read.ftable write.ftable format.ftable print.ftable
> ### Keywords: category
> 
> ### ** Examples
> 
> ## Agresti (1990), page 157, Table 5.8.
> ## Not in ftable standard format, but o.k.
> file <- tempfile()
> cat("             Intercourse\n",
+     "Race  Gender     Yes  No\n",
+     "White Male        43 134\n",
+     "      Female      26 149\n",
+     "Black Male        29  23\n",
+     "      Female      22  36\n",
+     file = file)
> ft1 <- read.ftable(file)
> ft1
             Intercourse Yes  No
Race  Gender                    
White Male                43 134
      Female              26 149
Black Male                29  23
      Female              22  36
> unlink(file)
> 
> ## Agresti (1990), page 297, Table 8.16.
> ## Almost o.k., but misses the name of the row variable.
> file <- tempfile()
> cat("                      \"Tonsil Size\"\n",
+     "            \"Not Enl.\" \"Enl.\" \"Greatly Enl.\"\n",
+     "Noncarriers       497     560           269\n",
+     "Carriers           19      29            24\n",
+     file = file)
> ft <- read.ftable(file, skip = 2,
+                   row.var.names = "Status",
+                   col.vars = list("Tonsil Size" =
+                       c("Not Enl.", "Enl.", "Greatly Enl.")))
> ft
            Tonsil Size Not Enl. Enl. Greatly Enl.
Status                                            
Noncarriers                  497  560          269
Carriers                      19   29           24
> unlink(file)
> 
> ft22 <- ftable(Titanic, row.vars = 2:1, col.vars = 4:3)
> write.ftable(ft22, quote = FALSE) # is the same as
             Survived    No         Yes      
             Age      Child Adult Child Adult
Sex    Class                                 
Male   1st                0   118     5    57
       2nd                0   154    11    14
       3rd               35   387    13    75
       Crew               0   670     0   192
Female 1st                0     4     1   140
       2nd                0    13    13    80
       3rd               17    89    14    76
       Crew               0     3     0    20
> print(ft22)#method="non.compact" is default
             Survived    No         Yes      
             Age      Child Adult Child Adult
Sex    Class                                 
Male   1st                0   118     5    57
       2nd                0   154    11    14
       3rd               35   387    13    75
       Crew               0   670     0   192
Female 1st                0     4     1   140
       2nd                0    13    13    80
       3rd               17    89    14    76
       Crew               0     3     0    20
> print(ft22, method="row.compact")
             Survived    No         Yes      
Sex    Class Age      Child Adult Child Adult
Male   1st                0   118     5    57
       2nd                0   154    11    14
       3rd               35   387    13    75
       Crew               0   670     0   192
Female 1st                0     4     1   140
       2nd                0    13    13    80
       3rd               17    89    14    76
       Crew               0     3     0    20
> print(ft22, method="col.compact")
       Survived    No         Yes      
       Age      Child Adult Child Adult
Sex    Class                           
Male   1st          0   118     5    57
       2nd          0   154    11    14
       3rd         35   387    13    75
       Crew         0   670     0   192
Female 1st          0     4     1   140
       2nd          0    13    13    80
       3rd         17    89    14    76
       Crew         0     3     0    20
> print(ft22, method="compact")
       Survived       No         Yes      
Sex    Class | Age Child Adult Child Adult
Male   1st             0   118     5    57
       2nd             0   154    11    14
       3rd            35   387    13    75
       Crew            0   670     0   192
Female 1st             0     4     1   140
       2nd             0    13    13    80
       3rd            17    89    14    76
       Crew            0     3     0    20
> 
> ## using 'justify' and 'quote' :
> format(ftable(wool + tension ~ breaks, warpbreaks),
+        justify = "none", quote = FALSE)
      [,1]     [,2]      [,3] [,4] [,5] [,6] [,7] [,8]
 [1,] ""       "wool"    "A"  ""   ""   "B"  ""   ""  
 [2,] ""       "tension" "L"  "M"  "H"  "L"  "M"  "H" 
 [3,] "breaks" ""        ""   ""   ""   ""   ""   ""  
 [4,] "10"     ""        "0"  "0"  "1"  "0"  "0"  "0" 
 [5,] "12"     ""        "0"  "1"  "0"  "0"  "0"  "0" 
 [6,] "13"     ""        "0"  "0"  "0"  "0"  "0"  "1" 
 [7,] "14"     ""        "0"  "0"  "0"  "1"  "0"  "0" 
 [8,] "15"     ""        "0"  "0"  "1"  "0"  "0"  "2" 
 [9,] "16"     ""        "0"  "0"  "0"  "0"  "1"  "1" 
[10,] "17"     ""        "0"  "1"  "0"  "0"  "0"  "1" 
[11,] "18"     ""        "0"  "2"  "1"  "0"  "0"  "0" 
[12,] "19"     ""        "0"  "0"  "0"  "1"  "1"  "0" 
[13,] "20"     ""        "0"  "0"  "0"  "1"  "0"  "1" 
[14,] "21"     ""        "0"  "1"  "1"  "0"  "1"  "1" 
[15,] "24"     ""        "0"  "0"  "1"  "0"  "0"  "1" 
[16,] "25"     ""        "1"  "0"  "0"  "0"  "0"  "0" 
[17,] "26"     ""        "2"  "0"  "1"  "0"  "1"  "0" 
[18,] "27"     ""        "0"  "0"  "0"  "1"  "0"  "0" 
[19,] "28"     ""        "0"  "0"  "1"  "0"  "1"  "1" 
[20,] "29"     ""        "0"  "1"  "0"  "2"  "1"  "0" 
[21,] "30"     ""        "1"  "1"  "0"  "0"  "0"  "0" 
[22,] "31"     ""        "0"  "0"  "0"  "1"  "0"  "0" 
[23,] "35"     ""        "0"  "1"  "0"  "0"  "0"  "0" 
[24,] "36"     ""        "0"  "1"  "1"  "0"  "0"  "0" 
[25,] "39"     ""        "0"  "0"  "0"  "0"  "2"  "0" 
[26,] "41"     ""        "0"  "0"  "0"  "1"  "0"  "0" 
[27,] "42"     ""        "0"  "0"  "0"  "0"  "1"  "0" 
[28,] "43"     ""        "0"  "0"  "1"  "0"  "0"  "0" 
[29,] "44"     ""        "0"  "0"  "0"  "1"  "0"  "0" 
[30,] "51"     ""        "1"  "0"  "0"  "0"  "0"  "0" 
[31,] "52"     ""        "1"  "0"  "0"  "0"  "0"  "0" 
[32,] "54"     ""        "1"  "0"  "0"  "0"  "0"  "0" 
[33,] "67"     ""        "1"  "0"  "0"  "0"  "0"  "0" 
[34,] "70"     ""        "1"  "0"  "0"  "0"  "0"  "0" 
> ## Don't show: 
>  op <- options(warn = 2) # no warnings allowed
>  stopifnot(dim(format(ft)) == 4:5,
+ 	   dim(format(ftable(UCBAdmissions))) == c(6,9))
>  meths <- c("non.compact", "row.compact", "col.compact", "compact")
>  dimform <-
+     function(ft) sapply(meths, function(M) dim(format(ft, method = M)))
>  m.eq    <- function(M,m) all.equal(unname(M), m, tolerance = 0)
>  ## All format(..) w/o warnings:
>  stopifnot(m.eq(print(dimform(ft22)),
+ 		rbind(11:10, rep(7:6, each = 2))),
+ 	   m.eq(print(dimform(ftable(Titanic, row.vars = integer()))),
+ 		rbind(rep(6:5,2), 33)))
     non.compact row.compact col.compact compact
[1,]          11          10          11      10
[2,]           7           7           6       6
     non.compact row.compact col.compact compact
[1,]           6           5           6       5
[2,]          33          33          33      33
>  options(op)
> ## End(Don't show)
> 
> 
> 
> cleanEx()
> nameEx("rect.hclust")
> ### * rect.hclust
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: rect.hclust
> ### Title: Draw Rectangles Around Hierarchical Clusters
> ### Aliases: rect.hclust
> ### Keywords: aplot cluster
> 
> ### ** Examples
> 
> require(graphics)
> 
> hca <- hclust(dist(USArrests))
> plot(hca)
> rect.hclust(hca, k = 3, border = "red")
> x <- rect.hclust(hca, h = 50, which = c(2,7), border = 3:4)
> x
[[1]]
       Alabama         Alaska       Delaware      Louisiana    Mississippi 
             1              2              8             18             24 
South Carolina 
            40 

[[2]]
 Connecticut        Idaho      Indiana       Kansas     Kentucky      Montana 
           7           12           14           16           17           26 
    Nebraska         Ohio Pennsylvania         Utah 
          27           35           38           44 

> 
> 
> 
> cleanEx()
> nameEx("relevel")
> ### * relevel
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: relevel
> ### Title: Reorder Levels of Factor
> ### Aliases: relevel relevel.default relevel.factor relevel.ordered
> ### Keywords: utilities models
> 
> ### ** Examples
> 
> warpbreaks$tension <- relevel(warpbreaks$tension, ref = "M")
> summary(lm(breaks ~ wool + tension, data = warpbreaks))

Call:
lm(formula = breaks ~ wool + tension, data = warpbreaks)

Residuals:
    Min      1Q  Median      3Q     Max 
-19.500  -8.083  -2.139   6.472  30.722 

Coefficients:
            Estimate Std. Error t value Pr(>|t|)    
(Intercept)   29.278      3.162   9.260    2e-12 ***
woolB         -5.778      3.162  -1.827   0.0736 .  
tensionL      10.000      3.872   2.582   0.0128 *  
tensionH      -4.722      3.872  -1.219   0.2284    
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 11.62 on 50 degrees of freedom
Multiple R-squared:  0.2691,	Adjusted R-squared:  0.2253 
F-statistic: 6.138 on 3 and 50 DF,  p-value: 0.00123

> 
> 
> 
> cleanEx()
> nameEx("reorder.dendrogram")
> ### * reorder.dendrogram
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: reorder.dendrogram
> ### Title: Reorder a Dendrogram
> ### Aliases: reorder.dendrogram
> ### Keywords: manip
> 
> ### ** Examples
> 
> require(graphics)
> 
> set.seed(123)
> x <- rnorm(10)
> hc <- hclust(dist(x))
> dd <- as.dendrogram(hc)
> dd.reorder <- reorder(dd, 10:1)
> plot(dd, main = "random dendrogram 'dd'")
> 
> op <- par(mfcol = 1:2)
> plot(dd.reorder, main = "reorder(dd, 10:1)")
> plot(reorder(dd, 10:1, agglo.FUN = mean), main = "reorder(dd, 10:1, mean)")
> par(op)
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("reorder.factor")
> ### * reorder.factor
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: reorder.default
> ### Title: Reorder Levels of a Factor
> ### Aliases: reorder reorder.default
> ### Keywords: utilities
> 
> ### ** Examples
> 
> require(graphics)
> 
> bymedian <- with(InsectSprays, reorder(spray, count, median))
> boxplot(count ~ bymedian, data = InsectSprays,
+         xlab = "Type of spray", ylab = "Insect count",
+         main = "InsectSprays data", varwidth = TRUE,
+         col = "lightgray")
> 
> bymedianR <- with(InsectSprays, reorder(spray, count, median, decreasing=TRUE))
> stopifnot(exprs = {
+     identical(attr(bymedian, "scores") -> sc,
+               attr(bymedianR,"scores"))
+     identical(nms <- names(sc), LETTERS[1:6])
+     identical(levels(bymedian ), nms[isc <- order(sc)])
+     identical(levels(bymedianR), nms[rev(isc)])
+ })
> 
> 
> 
> cleanEx()
> nameEx("replications")
> ### * replications
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: replications
> ### Title: Number of Replications of Terms
> ### Aliases: replications
> ### Keywords: models
> 
> ### ** Examples
> 
> ## From Venables and Ripley (2002) p.165.
> N <- c(0,1,0,1,1,1,0,0,0,1,1,0,1,1,0,0,1,0,1,0,1,1,0,0)
> P <- c(1,1,0,0,0,1,0,1,1,1,0,0,0,1,0,1,1,0,0,1,0,1,1,0)
> K <- c(1,0,0,1,0,1,1,0,0,1,0,1,0,1,1,0,0,0,1,1,1,0,1,0)
> yield <- c(49.5,62.8,46.8,57.0,59.8,58.5,55.5,56.0,62.8,55.8,69.5,
+ 55.0, 62.0,48.8,45.5,44.2,52.0,51.5,49.8,48.8,57.2,59.0,53.2,56.0)
> 
> npk <- data.frame(block = gl(6,4), N = factor(N), P = factor(P),
+                   K = factor(K), yield = yield)
> replications(~ . - yield, npk)
block     N     P     K 
    4    12    12    12 
> 
> 
> 
> cleanEx()
> nameEx("reshape")
> ### * reshape
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: reshape
> ### Title: Reshape Grouped Data
> ### Aliases: reshape
> ### Keywords: manip
> 
> ### ** Examples
> 
> summary(Indometh) # data in long format
 Subject      time            conc       
 1:11    Min.   :0.250   Min.   :0.0500  
 4:11    1st Qu.:0.750   1st Qu.:0.1100  
 2:11    Median :2.000   Median :0.3400  
 5:11    Mean   :2.886   Mean   :0.5918  
 6:11    3rd Qu.:5.000   3rd Qu.:0.8325  
 3:11    Max.   :8.000   Max.   :2.7200  
> 
> ## long to wide (direction = "wide") requires idvar and timevar at a minimum
> reshape(Indometh, direction = "wide", idvar = "Subject", timevar = "time")
   Subject conc.0.25 conc.0.5 conc.0.75 conc.1 conc.1.25 conc.2 conc.3 conc.4
1        1      1.50     0.94      0.78   0.48      0.37   0.19   0.12   0.11
12       2      2.03     1.63      0.71   0.70      0.64   0.36   0.32   0.20
23       3      2.72     1.49      1.16   0.80      0.80   0.39   0.22   0.12
34       4      1.85     1.39      1.02   0.89      0.59   0.40   0.16   0.11
45       5      2.05     1.04      0.81   0.39      0.30   0.23   0.13   0.11
56       6      2.31     1.44      1.03   0.84      0.64   0.42   0.24   0.17
   conc.5 conc.6 conc.8
1    0.08   0.07   0.05
12   0.25   0.12   0.08
23   0.11   0.08   0.08
34   0.10   0.07   0.07
45   0.08   0.10   0.06
56   0.13   0.10   0.09
> 
> ## can also explicitly specify name of combined variable
> wide <- reshape(Indometh, direction = "wide", idvar = "Subject",
+                 timevar = "time", v.names = "conc", sep= "_")
> wide
   Subject conc_0.25 conc_0.5 conc_0.75 conc_1 conc_1.25 conc_2 conc_3 conc_4
1        1      1.50     0.94      0.78   0.48      0.37   0.19   0.12   0.11
12       2      2.03     1.63      0.71   0.70      0.64   0.36   0.32   0.20
23       3      2.72     1.49      1.16   0.80      0.80   0.39   0.22   0.12
34       4      1.85     1.39      1.02   0.89      0.59   0.40   0.16   0.11
45       5      2.05     1.04      0.81   0.39      0.30   0.23   0.13   0.11
56       6      2.31     1.44      1.03   0.84      0.64   0.42   0.24   0.17
   conc_5 conc_6 conc_8
1    0.08   0.07   0.05
12   0.25   0.12   0.08
23   0.11   0.08   0.08
34   0.10   0.07   0.07
45   0.08   0.10   0.06
56   0.13   0.10   0.09
> 
> ## reverse transformation
> reshape(wide, direction = "long")
       Subject time conc
1.0.25       1 0.25 1.50
2.0.25       2 0.25 2.03
3.0.25       3 0.25 2.72
4.0.25       4 0.25 1.85
5.0.25       5 0.25 2.05
6.0.25       6 0.25 2.31
1.0.5        1 0.50 0.94
2.0.5        2 0.50 1.63
3.0.5        3 0.50 1.49
4.0.5        4 0.50 1.39
5.0.5        5 0.50 1.04
6.0.5        6 0.50 1.44
1.0.75       1 0.75 0.78
2.0.75       2 0.75 0.71
3.0.75       3 0.75 1.16
4.0.75       4 0.75 1.02
5.0.75       5 0.75 0.81
6.0.75       6 0.75 1.03
1.1          1 1.00 0.48
2.1          2 1.00 0.70
3.1          3 1.00 0.80
4.1          4 1.00 0.89
5.1          5 1.00 0.39
6.1          6 1.00 0.84
1.1.25       1 1.25 0.37
2.1.25       2 1.25 0.64
3.1.25       3 1.25 0.80
4.1.25       4 1.25 0.59
5.1.25       5 1.25 0.30
6.1.25       6 1.25 0.64
1.2          1 2.00 0.19
2.2          2 2.00 0.36
3.2          3 2.00 0.39
4.2          4 2.00 0.40
5.2          5 2.00 0.23
6.2          6 2.00 0.42
1.3          1 3.00 0.12
2.3          2 3.00 0.32
3.3          3 3.00 0.22
4.3          4 3.00 0.16
5.3          5 3.00 0.13
6.3          6 3.00 0.24
1.4          1 4.00 0.11
2.4          2 4.00 0.20
3.4          3 4.00 0.12
4.4          4 4.00 0.11
5.4          5 4.00 0.11
6.4          6 4.00 0.17
1.5          1 5.00 0.08
2.5          2 5.00 0.25
3.5          3 5.00 0.11
4.5          4 5.00 0.10
5.5          5 5.00 0.08
6.5          6 5.00 0.13
1.6          1 6.00 0.07
2.6          2 6.00 0.12
3.6          3 6.00 0.08
4.6          4 6.00 0.07
5.6          5 6.00 0.10
6.6          6 6.00 0.10
1.8          1 8.00 0.05
2.8          2 8.00 0.08
3.8          3 8.00 0.08
4.8          4 8.00 0.07
5.8          5 8.00 0.06
6.8          6 8.00 0.09
> reshape(wide, idvar = "Subject", varying = list(2:12),
+         v.names = "conc", direction = "long")
     Subject time conc
1.1        1    1 1.50
2.1        2    1 2.03
3.1        3    1 2.72
4.1        4    1 1.85
5.1        5    1 2.05
6.1        6    1 2.31
1.2        1    2 0.94
2.2        2    2 1.63
3.2        3    2 1.49
4.2        4    2 1.39
5.2        5    2 1.04
6.2        6    2 1.44
1.3        1    3 0.78
2.3        2    3 0.71
3.3        3    3 1.16
4.3        4    3 1.02
5.3        5    3 0.81
6.3        6    3 1.03
1.4        1    4 0.48
2.4        2    4 0.70
3.4        3    4 0.80
4.4        4    4 0.89
5.4        5    4 0.39
6.4        6    4 0.84
1.5        1    5 0.37
2.5        2    5 0.64
3.5        3    5 0.80
4.5        4    5 0.59
5.5        5    5 0.30
6.5        6    5 0.64
1.6        1    6 0.19
2.6        2    6 0.36
3.6        3    6 0.39
4.6        4    6 0.40
5.6        5    6 0.23
6.6        6    6 0.42
1.7        1    7 0.12
2.7        2    7 0.32
3.7        3    7 0.22
4.7        4    7 0.16
5.7        5    7 0.13
6.7        6    7 0.24
1.8        1    8 0.11
2.8        2    8 0.20
3.8        3    8 0.12
4.8        4    8 0.11
5.8        5    8 0.11
6.8        6    8 0.17
1.9        1    9 0.08
2.9        2    9 0.25
3.9        3    9 0.11
4.9        4    9 0.10
5.9        5    9 0.08
6.9        6    9 0.13
1.10       1   10 0.07
2.10       2   10 0.12
3.10       3   10 0.08
4.10       4   10 0.07
5.10       5   10 0.10
6.10       6   10 0.10
1.11       1   11 0.05
2.11       2   11 0.08
3.11       3   11 0.08
4.11       4   11 0.07
5.11       5   11 0.06
6.11       6   11 0.09
> 
> ## times need not be numeric
> df <- data.frame(id = rep(1:4, rep(2,4)),
+                  visit = I(rep(c("Before","After"), 4)),
+                  x = rnorm(4), y = runif(4))
> df
  id  visit          x          y
1  1 Before -0.6264538 0.62911404
2  1  After  0.1836433 0.06178627
3  2 Before -0.8356286 0.20597457
4  2  After  1.5952808 0.17655675
5  3 Before -0.6264538 0.62911404
6  3  After  0.1836433 0.06178627
7  4 Before -0.8356286 0.20597457
8  4  After  1.5952808 0.17655675
> reshape(df, timevar = "visit", idvar = "id", direction = "wide")
  id   x.Before  y.Before   x.After    y.After
1  1 -0.6264538 0.6291140 0.1836433 0.06178627
3  2 -0.8356286 0.2059746 1.5952808 0.17655675
5  3 -0.6264538 0.6291140 0.1836433 0.06178627
7  4 -0.8356286 0.2059746 1.5952808 0.17655675
> ## warns that y is really varying
> reshape(df, timevar = "visit", idvar = "id", direction = "wide", v.names = "x")
Warning in reshapeWide(data, idvar = idvar, timevar = timevar, varying = varying,  :
  some constant variables (y) are really varying
  id         y   x.Before   x.After
1  1 0.6291140 -0.6264538 0.1836433
3  2 0.2059746 -0.8356286 1.5952808
5  3 0.6291140 -0.6264538 0.1836433
7  4 0.2059746 -0.8356286 1.5952808
> 
> 
> ##  unbalanced 'long' data leads to NA fill in 'wide' form
> df2 <- df[1:7, ]
> df2
  id  visit          x          y
1  1 Before -0.6264538 0.62911404
2  1  After  0.1836433 0.06178627
3  2 Before -0.8356286 0.20597457
4  2  After  1.5952808 0.17655675
5  3 Before -0.6264538 0.62911404
6  3  After  0.1836433 0.06178627
7  4 Before -0.8356286 0.20597457
> reshape(df2, timevar = "visit", idvar = "id", direction = "wide")
  id   x.Before  y.Before   x.After    y.After
1  1 -0.6264538 0.6291140 0.1836433 0.06178627
3  2 -0.8356286 0.2059746 1.5952808 0.17655675
5  3 -0.6264538 0.6291140 0.1836433 0.06178627
7  4 -0.8356286 0.2059746        NA         NA
> 
> ## Alternative regular expressions for guessing names
> df3 <- data.frame(id = 1:4, age = c(40,50,60,50), dose1 = c(1,2,1,2),
+                   dose2 = c(2,1,2,1), dose4 = c(3,3,3,3))
> reshape(df3, direction = "long", varying = 3:5, sep = "")
    id age time dose
1.1  1  40    1    1
2.1  2  50    1    2
3.1  3  60    1    1
4.1  4  50    1    2
1.2  1  40    2    2
2.2  2  50    2    1
3.2  3  60    2    2
4.2  4  50    2    1
1.4  1  40    4    3
2.4  2  50    4    3
3.4  3  60    4    3
4.4  4  50    4    3
> 
> 
> ## an example that isn't longitudinal data
> state.x77 <- as.data.frame(state.x77)
> long <- reshape(state.x77, idvar = "state", ids = row.names(state.x77),
+                 times = names(state.x77), timevar = "Characteristic",
+                 varying = list(names(state.x77)), direction = "long")
> 
> reshape(long, direction = "wide")
                                   state Population Income Illiteracy Life Exp
Alabama.Population               Alabama       3615   3624        2.1    69.05
Alaska.Population                 Alaska        365   6315        1.5    69.31
Arizona.Population               Arizona       2212   4530        1.8    70.55
Arkansas.Population             Arkansas       2110   3378        1.9    70.66
California.Population         California      21198   5114        1.1    71.71
Colorado.Population             Colorado       2541   4884        0.7    72.06
Connecticut.Population       Connecticut       3100   5348        1.1    72.48
Delaware.Population             Delaware        579   4809        0.9    70.06
Florida.Population               Florida       8277   4815        1.3    70.66
Georgia.Population               Georgia       4931   4091        2.0    68.54
Hawaii.Population                 Hawaii        868   4963        1.9    73.60
Idaho.Population                   Idaho        813   4119        0.6    71.87
Illinois.Population             Illinois      11197   5107        0.9    70.14
Indiana.Population               Indiana       5313   4458        0.7    70.88
Iowa.Population                     Iowa       2861   4628        0.5    72.56
Kansas.Population                 Kansas       2280   4669        0.6    72.58
Kentucky.Population             Kentucky       3387   3712        1.6    70.10
Louisiana.Population           Louisiana       3806   3545        2.8    68.76
Maine.Population                   Maine       1058   3694        0.7    70.39
Maryland.Population             Maryland       4122   5299        0.9    70.22
Massachusetts.Population   Massachusetts       5814   4755        1.1    71.83
Michigan.Population             Michigan       9111   4751        0.9    70.63
Minnesota.Population           Minnesota       3921   4675        0.6    72.96
Mississippi.Population       Mississippi       2341   3098        2.4    68.09
Missouri.Population             Missouri       4767   4254        0.8    70.69
Montana.Population               Montana        746   4347        0.6    70.56
Nebraska.Population             Nebraska       1544   4508        0.6    72.60
Nevada.Population                 Nevada        590   5149        0.5    69.03
New Hampshire.Population   New Hampshire        812   4281        0.7    71.23
New Jersey.Population         New Jersey       7333   5237        1.1    70.93
New Mexico.Population         New Mexico       1144   3601        2.2    70.32
New York.Population             New York      18076   4903        1.4    70.55
North Carolina.Population North Carolina       5441   3875        1.8    69.21
North Dakota.Population     North Dakota        637   5087        0.8    72.78
Ohio.Population                     Ohio      10735   4561        0.8    70.82
Oklahoma.Population             Oklahoma       2715   3983        1.1    71.42
Oregon.Population                 Oregon       2284   4660        0.6    72.13
Pennsylvania.Population     Pennsylvania      11860   4449        1.0    70.43
Rhode Island.Population     Rhode Island        931   4558        1.3    71.90
South Carolina.Population South Carolina       2816   3635        2.3    67.96
South Dakota.Population     South Dakota        681   4167        0.5    72.08
Tennessee.Population           Tennessee       4173   3821        1.7    70.11
Texas.Population                   Texas      12237   4188        2.2    70.90
Utah.Population                     Utah       1203   4022        0.6    72.90
Vermont.Population               Vermont        472   3907        0.6    71.64
Virginia.Population             Virginia       4981   4701        1.4    70.08
Washington.Population         Washington       3559   4864        0.6    71.72
West Virginia.Population   West Virginia       1799   3617        1.4    69.48
Wisconsin.Population           Wisconsin       4589   4468        0.7    72.48
Wyoming.Population               Wyoming        376   4566        0.6    70.29
                          Murder HS Grad Frost   Area
Alabama.Population          15.1    41.3    20  50708
Alaska.Population           11.3    66.7   152 566432
Arizona.Population           7.8    58.1    15 113417
Arkansas.Population         10.1    39.9    65  51945
California.Population       10.3    62.6    20 156361
Colorado.Population          6.8    63.9   166 103766
Connecticut.Population       3.1    56.0   139   4862
Delaware.Population          6.2    54.6   103   1982
Florida.Population          10.7    52.6    11  54090
Georgia.Population          13.9    40.6    60  58073
Hawaii.Population            6.2    61.9     0   6425
Idaho.Population             5.3    59.5   126  82677
Illinois.Population         10.3    52.6   127  55748
Indiana.Population           7.1    52.9   122  36097
Iowa.Population              2.3    59.0   140  55941
Kansas.Population            4.5    59.9   114  81787
Kentucky.Population         10.6    38.5    95  39650
Louisiana.Population        13.2    42.2    12  44930
Maine.Population             2.7    54.7   161  30920
Maryland.Population          8.5    52.3   101   9891
Massachusetts.Population     3.3    58.5   103   7826
Michigan.Population         11.1    52.8   125  56817
Minnesota.Population         2.3    57.6   160  79289
Mississippi.Population      12.5    41.0    50  47296
Missouri.Population          9.3    48.8   108  68995
Montana.Population           5.0    59.2   155 145587
Nebraska.Population          2.9    59.3   139  76483
Nevada.Population           11.5    65.2   188 109889
New Hampshire.Population     3.3    57.6   174   9027
New Jersey.Population        5.2    52.5   115   7521
New Mexico.Population        9.7    55.2   120 121412
New York.Population         10.9    52.7    82  47831
North Carolina.Population   11.1    38.5    80  48798
North Dakota.Population      1.4    50.3   186  69273
Ohio.Population              7.4    53.2   124  40975
Oklahoma.Population          6.4    51.6    82  68782
Oregon.Population            4.2    60.0    44  96184
Pennsylvania.Population      6.1    50.2   126  44966
Rhode Island.Population      2.4    46.4   127   1049
South Carolina.Population   11.6    37.8    65  30225
South Dakota.Population      1.7    53.3   172  75955
Tennessee.Population        11.0    41.8    70  41328
Texas.Population            12.2    47.4    35 262134
Utah.Population              4.5    67.3   137  82096
Vermont.Population           5.5    57.1   168   9267
Virginia.Population          9.5    47.8    85  39780
Washington.Population        4.3    63.5    32  66570
West Virginia.Population     6.7    41.6   100  24070
Wisconsin.Population         3.0    54.5   149  54464
Wyoming.Population           6.9    62.9   173  97203
> 
> reshape(long, direction = "wide", new.row.names = unique(long$state))
                        state Population Income Illiteracy Life Exp Murder
Alabama               Alabama       3615   3624        2.1    69.05   15.1
Alaska                 Alaska        365   6315        1.5    69.31   11.3
Arizona               Arizona       2212   4530        1.8    70.55    7.8
Arkansas             Arkansas       2110   3378        1.9    70.66   10.1
California         California      21198   5114        1.1    71.71   10.3
Colorado             Colorado       2541   4884        0.7    72.06    6.8
Connecticut       Connecticut       3100   5348        1.1    72.48    3.1
Delaware             Delaware        579   4809        0.9    70.06    6.2
Florida               Florida       8277   4815        1.3    70.66   10.7
Georgia               Georgia       4931   4091        2.0    68.54   13.9
Hawaii                 Hawaii        868   4963        1.9    73.60    6.2
Idaho                   Idaho        813   4119        0.6    71.87    5.3
Illinois             Illinois      11197   5107        0.9    70.14   10.3
Indiana               Indiana       5313   4458        0.7    70.88    7.1
Iowa                     Iowa       2861   4628        0.5    72.56    2.3
Kansas                 Kansas       2280   4669        0.6    72.58    4.5
Kentucky             Kentucky       3387   3712        1.6    70.10   10.6
Louisiana           Louisiana       3806   3545        2.8    68.76   13.2
Maine                   Maine       1058   3694        0.7    70.39    2.7
Maryland             Maryland       4122   5299        0.9    70.22    8.5
Massachusetts   Massachusetts       5814   4755        1.1    71.83    3.3
Michigan             Michigan       9111   4751        0.9    70.63   11.1
Minnesota           Minnesota       3921   4675        0.6    72.96    2.3
Mississippi       Mississippi       2341   3098        2.4    68.09   12.5
Missouri             Missouri       4767   4254        0.8    70.69    9.3
Montana               Montana        746   4347        0.6    70.56    5.0
Nebraska             Nebraska       1544   4508        0.6    72.60    2.9
Nevada                 Nevada        590   5149        0.5    69.03   11.5
New Hampshire   New Hampshire        812   4281        0.7    71.23    3.3
New Jersey         New Jersey       7333   5237        1.1    70.93    5.2
New Mexico         New Mexico       1144   3601        2.2    70.32    9.7
New York             New York      18076   4903        1.4    70.55   10.9
North Carolina North Carolina       5441   3875        1.8    69.21   11.1
North Dakota     North Dakota        637   5087        0.8    72.78    1.4
Ohio                     Ohio      10735   4561        0.8    70.82    7.4
Oklahoma             Oklahoma       2715   3983        1.1    71.42    6.4
Oregon                 Oregon       2284   4660        0.6    72.13    4.2
Pennsylvania     Pennsylvania      11860   4449        1.0    70.43    6.1
Rhode Island     Rhode Island        931   4558        1.3    71.90    2.4
South Carolina South Carolina       2816   3635        2.3    67.96   11.6
South Dakota     South Dakota        681   4167        0.5    72.08    1.7
Tennessee           Tennessee       4173   3821        1.7    70.11   11.0
Texas                   Texas      12237   4188        2.2    70.90   12.2
Utah                     Utah       1203   4022        0.6    72.90    4.5
Vermont               Vermont        472   3907        0.6    71.64    5.5
Virginia             Virginia       4981   4701        1.4    70.08    9.5
Washington         Washington       3559   4864        0.6    71.72    4.3
West Virginia   West Virginia       1799   3617        1.4    69.48    6.7
Wisconsin           Wisconsin       4589   4468        0.7    72.48    3.0
Wyoming               Wyoming        376   4566        0.6    70.29    6.9
               HS Grad Frost   Area
Alabama           41.3    20  50708
Alaska            66.7   152 566432
Arizona           58.1    15 113417
Arkansas          39.9    65  51945
California        62.6    20 156361
Colorado          63.9   166 103766
Connecticut       56.0   139   4862
Delaware          54.6   103   1982
Florida           52.6    11  54090
Georgia           40.6    60  58073
Hawaii            61.9     0   6425
Idaho             59.5   126  82677
Illinois          52.6   127  55748
Indiana           52.9   122  36097
Iowa              59.0   140  55941
Kansas            59.9   114  81787
Kentucky          38.5    95  39650
Louisiana         42.2    12  44930
Maine             54.7   161  30920
Maryland          52.3   101   9891
Massachusetts     58.5   103   7826
Michigan          52.8   125  56817
Minnesota         57.6   160  79289
Mississippi       41.0    50  47296
Missouri          48.8   108  68995
Montana           59.2   155 145587
Nebraska          59.3   139  76483
Nevada            65.2   188 109889
New Hampshire     57.6   174   9027
New Jersey        52.5   115   7521
New Mexico        55.2   120 121412
New York          52.7    82  47831
North Carolina    38.5    80  48798
North Dakota      50.3   186  69273
Ohio              53.2   124  40975
Oklahoma          51.6    82  68782
Oregon            60.0    44  96184
Pennsylvania      50.2   126  44966
Rhode Island      46.4   127   1049
South Carolina    37.8    65  30225
South Dakota      53.3   172  75955
Tennessee         41.8    70  41328
Texas             47.4    35 262134
Utah              67.3   137  82096
Vermont           57.1   168   9267
Virginia          47.8    85  39780
Washington        63.5    32  66570
West Virginia     41.6   100  24070
Wisconsin         54.5   149  54464
Wyoming           62.9   173  97203
> 
> ## multiple id variables
> df3 <- data.frame(school = rep(1:3, each = 4), class = rep(9:10, 6),
+                   time = rep(c(1,1,2,2), 3), score = rnorm(12))
> wide <- reshape(df3, idvar = c("school", "class"), direction = "wide")
> wide
   school class     score.1     score.2
1       1     9  0.48742905  0.57578135
2       1    10  0.73832471 -0.30538839
5       2     9  1.51178117 -0.62124058
6       2    10  0.38984324 -2.21469989
9       3     9  1.12493092 -0.01619026
10      3    10 -0.04493361  0.94383621
> ## transform back
> reshape(wide)
       school class time     score.1
1.9.1       1     9    1  0.48742905
1.10.1      1    10    1  0.73832471
2.9.1       2     9    1  1.51178117
2.10.1      2    10    1  0.38984324
3.9.1       3     9    1  1.12493092
3.10.1      3    10    1 -0.04493361
1.9.2       1     9    2  0.57578135
1.10.2      1    10    2 -0.30538839
2.9.2       2     9    2 -0.62124058
2.10.2      2    10    2 -2.21469989
3.9.2       3     9    2 -0.01619026
3.10.2      3    10    2  0.94383621
> 
> 
> 
> 
> cleanEx()
> nameEx("runmed")
> ### * runmed
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: runmed
> ### Title: Running Medians - Robust Scatter Plot Smoothing
> ### Aliases: runmed
> ### Keywords: smooth robust
> 
> ### ** Examples
> 
> require(graphics)
> 
> utils::example(nhtemp)

nhtemp> require(stats); require(graphics)

nhtemp> plot(nhtemp, main = "nhtemp data",
nhtemp+   ylab = "Mean annual temperature in New Haven, CT (deg. F)")
> myNHT <- as.vector(nhtemp)
> myNHT[20] <- 2 * nhtemp[20]
> plot(myNHT, type = "b", ylim = c(48, 60), main = "Running Medians Example")
> lines(runmed(myNHT, 7), col = "red")
> 
> ## special: multiple y values for one x
> plot(cars, main = "'cars' data and runmed(dist, 3)")
> lines(cars, col = "light gray", type = "c")
> with(cars, lines(speed, runmed(dist, k = 3), col = 2))
> 
> ## nice quadratic with a few outliers
> y <- ys <- (-20:20)^2
> y [c(1,10,21,41)] <- c(150, 30, 400, 450)
> all(y == runmed(y, 1)) # 1-neighbourhood <==> interpolation
[1] TRUE
> plot(y) ## lines(y, lwd = .1, col = "light gray")
> lines(lowess(seq(y), y, f = 0.3), col = "brown")
> lines(runmed(y, 7), lwd = 2, col = "blue")
> lines(runmed(y, 11), lwd = 2, col = "red")
> 
> ## Lowess is not robust
> y <- ys ; y[21] <- 6666 ; x <- seq(y)
> col <- c("black", "brown","blue")
> plot(y, col = col[1])
> lines(lowess(x, y, f = 0.3), col = col[2])
> lines(runmed(y, 7),      lwd = 2, col = col[3])
> legend(length(y),max(y), c("data", "lowess(y, f = 0.3)", "runmed(y, 7)"),
+        xjust = 1, col = col, lty = c(0, 1, 1), pch = c(1,NA,NA))
> 
> ## An example with initial NA's - used to fail badly (notably for "Turlach"):
> x15 <- c(rep(NA, 4), c(9, 9, 4, 22, 6, 1, 7, 5, 2, 8, 3))
> rS15 <- cbind(Sk.3 = runmed(x15, k = 3, algorithm="S"),
+               Sk.7 = runmed(x15, k = 7, algorithm="S"),
+               Sk.11= runmed(x15, k =11, algorithm="S"))
> rT15 <- cbind(Tk.3 = runmed(x15, k = 3, algorithm="T", print.level=1),
+               Tk.7 = runmed(x15, k = 7, algorithm="T", print.level=1),
+               Tk.9 = runmed(x15, k = 9, algorithm="T", print.level=1),
+               Tk.11= runmed(x15, k =11, algorithm="T", print.level=1))
runmed(x, k=3, endrule='median' ( => iend=0), algorithm='Turlach',
       na.*='+Big_alternate' ( => iNAct=1))
firstNA = 1.
R_heapsort(1, 3,..): l=2:
         j:      0     1     2     3     4     5     6
 window []:    -2B   -2B  -BIG  +BIG  +BIG   +2B   +2B
  nrlist[]: -12345     2     1     2     0-12345-12345
 outlist[]:      4     2     3     2
runmed(x, k=7, endrule='median' ( => iend=0), algorithm='Turlach',
       na.*='+Big_alternate' ( => iNAct=1))
firstNA = 1.
R_heapsort(1, 7,..): l=4:
         j:      0     1     2     3     4     5     6     7     8     9    10    11    12    13    14
 window []:    -2B   -2B   -2B   -2B  -BIG  -BIG     4     9     9  +BIG  +BIG   +2B   +2B   +2B   +2B
  nrlist[]: -12345     4     2     7     3     1     6     5     4     2     0-12345-12345-12345-12345
 outlist[]:     10     5     9     4     8     7     6     3
runmed(x, k=9, endrule='median' ( => iend=0), algorithm='Turlach',
       na.*='+Big_alternate' ( => iNAct=1))
firstNA = 1.
R_heapsort(1, 9,..): l=5:
         j:      0     1     2     3     4     5     6     7     8     9    10    11    12    13    14    15    16    17    18
 window []:    -2B   -2B   -2B   -2B   -2B  -BIG  -BIG     4     6     9     9    22  +BIG  +BIG   +2B   +2B   +2B   +2B   +2B
  nrlist[]: -12345     4     2     7     9     3     1     6     8     5     4     7     2     0-12345-12345-12345-12345-12345
 outlist[]:     13     6    12     5    10     9     7    11     8     4
runmed(x, k=11, endrule='median' ( => iend=0), algorithm='Turlach',
       na.*='+Big_alternate' ( => iNAct=1))
firstNA = 1.
R_heapsort(1, 11,..): l=6:
         j:      0     1     2     3     4     5     6     7     8     9    10    11    12    13    14    15    16    17    18    19    20    21    22
 window []:    -2B   -2B   -2B   -2B   -2B   -2B  -BIG  -BIG     1     4     6     7     9     9    22  +BIG  +BIG   +2B   +2B   +2B   +2B   +2B   +2B
  nrlist[]: -12345     2     4    10     7     9     1     3     9     6     8    10     5     4     7     2     0-12345-12345-12345-12345-12345-12345
 outlist[]:     16     6    15     7    13    12     9    14    10     8    11     6
> cbind(x15, rS15, rT15) # result for k=11  maybe a bit surprising ..
      x15 Sk.3 Sk.7 Sk.11 Tk.3 Tk.7 Tk.9 Tk.11
 [1,]  NA  NaN  NaN   NaN  NaN  NaN  NaN   NaN
 [2,]  NA   NA  NaN   NaN   NA  NaN  NaN   NaN
 [3,]  NA   NA    9     9   NA    9    9     9
 [4,]  NA    9    9     7    9    9    7     7
 [5,]   9    9    9     6    9    9    9     6
 [6,]   9    9    9     7    9    9    6     7
 [7,]   4    9    6     6    9    6    7     6
 [8,]  22    6    7     6    6    7    6     6
 [9,]   6    6    6     6    6    6    6     6
[10,]   1    6    5     6    6    5    6     6
[11,]   7    5    6     6    5    6    5     6
[12,]   5    5    5     6    5    5    5     6
[13,]   2    5    5     5    5    5    5     5
[14,]   8    3    3     3    3    3    3     3
[15,]   3    3    3     3    3    3    3     3
> Tv <- rT15[-(1:3),]
> stopifnot(3 <= Tv, Tv <= 9, 5 <= Tv[1:10,])
> matplot(y = cbind(x15, rT15), type = "b", ylim = c(1,9), pch=1:5, xlab = NA,
+         main = "runmed(x15, k, algo = \"Turlach\")")
> mtext(paste("x15 <-", deparse(x15)))
> points(x15, cex=2)
> legend("bottomleft", legend=c("data", paste("k = ", c(3,7,9,11))),
+        bty="n", col=1:5, lty=1:5, pch=1:5)
> 
> 
> 
> cleanEx()
> nameEx("scatter.smooth")
> ### * scatter.smooth
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: scatter.smooth
> ### Title: Scatter Plot with Smooth Curve Fitted by Loess
> ### Aliases: scatter.smooth loess.smooth
> ### Keywords: smooth
> 
> ### ** Examples
> 
> require(graphics)
> 
> with(cars, scatter.smooth(speed, dist))
> ## or with dotted thick smoothed line results :
> with(cars, scatter.smooth(speed, dist, lpars =
+                     list(col = "red", lwd = 3, lty = 3)))
> 
> 
> 
> cleanEx()
> nameEx("screeplot")
> ### * screeplot
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: screeplot
> ### Title: Screeplots
> ### Aliases: screeplot screeplot.default
> ### Keywords: multivariate
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## The variances of the variables in the
> ## USArrests data vary by orders of magnitude, so scaling is appropriate
> (pc.cr <- princomp(USArrests, cor = TRUE))  # inappropriate
Call:
princomp(x = USArrests, cor = TRUE)

Standard deviations:
   Comp.1    Comp.2    Comp.3    Comp.4 
1.5748783 0.9948694 0.5971291 0.4164494 

 4  variables and  50 observations.
> screeplot(pc.cr)
> 
> fit <- princomp(covmat = Harman74.cor)
> screeplot(fit)
> screeplot(fit, npcs = 24, type = "lines")
> 
> 
> 
> cleanEx()
> nameEx("sd")
> ### * sd
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: sd
> ### Title: Standard Deviation
> ### Aliases: sd
> ### Keywords: univar
> 
> ### ** Examples
> 
> sd(1:2) ^ 2
[1] 0.5
> 
> 
> 
> cleanEx()
> nameEx("se.contrast")
> ### * se.contrast
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: se.contrast
> ### Title: Standard Errors for Contrasts in Model Terms
> ### Aliases: se.contrast se.contrast.aov se.contrast.aovlist
> ### Keywords: models
> 
> ### ** Examples
> 
> ## From Venables and Ripley (2002) p.165.
> N <- c(0,1,0,1,1,1,0,0,0,1,1,0,1,1,0,0,1,0,1,0,1,1,0,0)
> P <- c(1,1,0,0,0,1,0,1,1,1,0,0,0,1,0,1,1,0,0,1,0,1,1,0)
> K <- c(1,0,0,1,0,1,1,0,0,1,0,1,0,1,1,0,0,0,1,1,1,0,1,0)
> yield <- c(49.5,62.8,46.8,57.0,59.8,58.5,55.5,56.0,62.8,55.8,69.5,
+ 55.0, 62.0,48.8,45.5,44.2,52.0,51.5,49.8,48.8,57.2,59.0,53.2,56.0)
> 
> npk <- data.frame(block = gl(6,4), N = factor(N), P = factor(P),
+                   K = factor(K), yield = yield)
> ## Set suitable contrasts.
> options(contrasts = c("contr.helmert", "contr.poly"))
> npk.aov1 <- aov(yield ~ block + N + K, data = npk)
> se.contrast(npk.aov1, list(N == "0", N == "1"), data = npk)
[1] 1.609175
> # or via a matrix
> cont <- matrix(c(-1,1), 2, 1, dimnames = list(NULL, "N"))
> se.contrast(npk.aov1, cont[N, , drop = FALSE]/12, data = npk)
       N 
1.609175 
> 
> ## test a multi-stratum model
> npk.aov2 <- aov(yield ~ N + K + Error(block/(N + K)), data = npk)
> se.contrast(npk.aov2, list(N == "0", N == "1"))
[1] 1.812166
> 
> 
> ## an example looking at an interaction contrast
> ## Dataset from R.E. Kirk (1995)
> ## 'Experimental Design: procedures for the behavioral sciences'
> score <- c(12, 8,10, 6, 8, 4,10,12, 8, 6,10,14, 9, 7, 9, 5,11,12,
+             7,13, 9, 9, 5,11, 8, 7, 3, 8,12,10,13,14,19, 9,16,14)
> A <- gl(2, 18, labels = c("a1", "a2"))
> B <- rep(gl(3, 6, labels = c("b1", "b2", "b3")), 2)
> fit <- aov(score ~ A*B)
> cont <- c(1, -1)[A] * c(1, -1, 0)[B]
> sum(cont)       # 0
[1] 0
> sum(cont*score) # value of the contrast
[1] -18
> se.contrast(fit, as.matrix(cont))
Contrast 1 
  14.24547 
> (t.stat <- sum(cont*score)/se.contrast(fit, as.matrix(cont)))
Contrast 1 
  -1.26356 
> summary(fit, split = list(B = 1:2), expand.split = TRUE)
            Df Sum Sq Mean Sq F value  Pr(>F)   
A            1  18.78   18.78   2.221 0.14661   
B            2  62.00   31.00   3.666 0.03763 * 
  B: C1      1   1.50    1.50   0.177 0.67662   
  B: C2      1  60.50   60.50   7.155 0.01199 * 
A:B          2  81.56   40.78   4.823 0.01527 * 
  A:B: C1    1  13.50   13.50   1.597 0.21612   
  A:B: C2    1  68.06   68.06   8.049 0.00809 **
Residuals   30 253.67    8.46                   
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
> ## t.stat^2 is the F value on the A:B: C1 line (with Helmert contrasts)
> ## Now look at all three interaction contrasts
> cont <- c(1, -1)[A] * cbind(c(1, -1, 0), c(1, 0, -1), c(0, 1, -1))[B,]
> se.contrast(fit, cont)  # same, due to balance.
Contrast 1 Contrast 2 Contrast 3 
  14.24547   14.24547   14.24547 
> rm(A, B, score)
> 
> 
> ## multi-stratum example where efficiencies play a role
> ## An example from Yates (1932),
> ## a 2^3 design in 2 blocks replicated 4 times
> 
> Block <- gl(8, 4)
> A <- factor(c(0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,
+               0,1,0,1,0,1,0,1,0,1,0,1))
> B <- factor(c(0,0,1,1,0,0,1,1,0,1,0,1,1,0,1,0,0,0,1,1,
+               0,0,1,1,0,0,1,1,0,0,1,1))
> C <- factor(c(0,1,1,0,1,0,0,1,0,0,1,1,0,0,1,1,0,1,0,1,
+               1,0,1,0,0,0,1,1,1,1,0,0))
> Yield <- c(101, 373, 398, 291, 312, 106, 265, 450, 106, 306, 324, 449,
+            272, 89, 407, 338, 87, 324, 279, 471, 323, 128, 423, 334,
+            131, 103, 445, 437, 324, 361, 302, 272)
> aovdat <- data.frame(Block, A, B, C, Yield)
> fit <- aov(Yield ~ A + B * C + Error(Block), data = aovdat)
> cont1 <- c(-1, 1)[A]/32  # Helmert contrasts
> cont2 <- c(-1, 1)[B] * c(-1, 1)[C]/32
> cont <- cbind(A = cont1, BC = cont2)
> colSums(cont*Yield) # values of the contrasts
        A        BC 
 10.40625 -20.90625 
> se.contrast(fit, as.matrix(cont))
       A       BC 
3.377196 3.899650 
> 
> 
> base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
> cleanEx()
> nameEx("selfStart")
> ### * selfStart
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: selfStart
> ### Title: Construct Self-starting Nonlinear Models
> ### Aliases: selfStart selfStart.default selfStart.formula
> ### Keywords: models
> 
> ### ** Examples
> 
> ## self-starting logistic model
> 
> ## The "initializer" (finds initial values for parameters from data):
> initLogis <- function(mCall, data, LHS, ...) {
+     xy <- sortedXyData(mCall[["x"]], LHS, data)
+     if(nrow(xy) < 4)
+         stop("too few distinct input values to fit a logistic model")
+     z <- xy[["y"]]
+     ## transform to proportion, i.e. in (0,1) :
+     rng <- range(z); dz <- diff(rng)
+     z <- (z - rng[1L] + 0.05 * dz)/(1.1 * dz)
+     xy[["z"]] <- log(z/(1 - z))		# logit transformation
+     aux <- coef(lm(x ~ z, xy))
+     pars <- coef(nls(y ~ 1/(1 + exp((xmid - x)/scal)),
+                      data = xy,
+                      start = list(xmid = aux[[1L]], scal = aux[[2L]]),
+                      algorithm = "plinear", ...))
+     setNames(pars [c(".lin", "xmid", "scal")],
+              mCall[c("Asym", "xmid", "scal")])
+ }
> 
> mySSlogis <- selfStart(~ Asym/(1 + exp((xmid - x)/scal)),
+                        initial = initLogis,
+                        parameters = c("Asym", "xmid", "scal"))
> ## Don't show: 
> ## IGNORE_RDIFF_BEGIN
> ## End(Don't show)
> getInitial(weight ~ mySSlogis(Time, Asym, xmid, scal),
+            data = subset(ChickWeight, Chick == 1))
     Asym      xmid      scal 
937.02983  35.22296  11.40521 
> ## Don't show: 
> ## IGNORE_RDIFF_END
> ## End(Don't show)
> 
> # 'first.order.log.model' is a function object defining a first order
> # compartment model
> # 'first.order.log.initial' is a function object which calculates initial
> # values for the parameters in 'first.order.log.model'
> #
> # self-starting first order compartment model
> ## Not run: 
> ##D SSfol <- selfStart(first.order.log.model, first.order.log.initial)
> ## End(Not run)
> 
> ## Explore the self-starting models already available in R's  "stats":
> pos.st <- which("package:stats" == search())
> mSS <- apropos("^SS..", where = TRUE, ignore.case = FALSE)
> (mSS <- unname(mSS[names(mSS) == pos.st]))
 [1] "SSasymp"     "SSasympOff"  "SSasympOrig" "SSbiexp"     "SSfol"      
 [6] "SSfpl"       "SSgompertz"  "SSlogis"     "SSmicmen"    "SSweibull"  
> fSS <- sapply(mSS, get, pos = pos.st, mode = "function")
> all(sapply(fSS, inherits, "selfStart"))  # -> TRUE
[1] TRUE
> 
> ## Show the argument list of each self-starting function:
> str(fSS, give.attr = FALSE)
List of 10
 $ SSasymp    :function (input, Asym, R0, lrc)  
 $ SSasympOff :function (input, Asym, lrc, c0)  
 $ SSasympOrig:function (input, Asym, lrc)  
 $ SSbiexp    :function (input, A1, lrc1, A2, lrc2)  
 $ SSfol      :function (Dose, input, lKe, lKa, lCl)  
 $ SSfpl      :function (input, A, B, xmid, scal)  
 $ SSgompertz :function (x, Asym, b2, b3)  
 $ SSlogis    :function (input, Asym, xmid, scal)  
 $ SSmicmen   :function (input, Vm, K)  
 $ SSweibull  :function (x, Asym, Drop, lrc, pwr)  
> 
> 
> 
> cleanEx()
> nameEx("setNames")
> ### * setNames
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: setNames
> ### Title: Set the Names in an Object
> ### Aliases: setNames
> ### Keywords: list
> 
> ### ** Examples
> 
> setNames( 1:3, c("foo", "bar", "baz") )
foo bar baz 
  1   2   3 
> # this is just a short form of
> tmp <- 1:3
> names(tmp) <-  c("foo", "bar", "baz")
> tmp
foo bar baz 
  1   2   3 
> 
> ## special case of character vector, using default
> setNames(nm = c("First", "2nd"))
  First     2nd 
"First"   "2nd" 
> 
> 
> 
> cleanEx()
> nameEx("shapiro.test")
> ### * shapiro.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: shapiro.test
> ### Title: Shapiro-Wilk Normality Test
> ### Aliases: shapiro.test
> ### Keywords: htest
> 
> ### ** Examples
> 
> shapiro.test(rnorm(100, mean = 5, sd = 3))

	Shapiro-Wilk normality test

data:  rnorm(100, mean = 5, sd = 3)
W = 0.9956, p-value = 0.9876

> shapiro.test(runif(100, min = 2, max = 4))

	Shapiro-Wilk normality test

data:  runif(100, min = 2, max = 4)
W = 0.93092, p-value = 5.616e-05

> 
> 
> 
> cleanEx()
> nameEx("sigma")
> ### * sigma
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: sigma
> ### Title: Extract Residual Standard Deviation 'Sigma'
> ### Aliases: sigma sigma.default sigma.mlm
> ### Keywords: models
> 
> ### ** Examples
> 
> ## -- lm() ------------------------------
> lm1 <- lm(Fertility ~ . , data = swiss)
> sigma(lm1) # ~= 7.165  = "Residual standard error"  printed from summary(lm1)
[1] 7.165369
> stopifnot(all.equal(sigma(lm1), summary(lm1)$sigma, tolerance=1e-15))
> 
> ## -- nls() -----------------------------
> DNase1 <- subset(DNase, Run == 1)
> fm.DN1 <- nls(density ~ SSlogis(log(conc), Asym, xmid, scal), DNase1)
> sigma(fm.DN1) # ~= 0.01919  as from summary(..)
[1] 0.01919449
> stopifnot(all.equal(sigma(fm.DN1), summary(fm.DN1)$sigma, tolerance=1e-15))
> 
> ## -- glm() -----------------------------
> ## -- a) Binomial -- Example from MASS
> ldose <- rep(0:5, 2)
> numdead <- c(1, 4, 9, 13, 18, 20, 0, 2, 6, 10, 12, 16)
> sex <- factor(rep(c("M", "F"), c(6, 6)))
> SF <- cbind(numdead, numalive = 20-numdead)
> sigma(budworm.lg <- glm(SF ~ sex*ldose, family = binomial))
[1] 0.7900734
> 
> ## -- b) Poisson -- from ?glm :
> ## Dobson (1990) Page 93: Randomized Controlled Trial :
> counts <- c(18,17,15,20,10,20,25,13,12)
> outcome <- gl(3,1,9)
> treatment <- gl(3,3)
> sigma(glm.D93 <- glm(counts ~ outcome + treatment, family = poisson()))
[1] 1.13238
> ## (currently) *differs* from
> summary(glm.D93)$dispersion # == 1
[1] 1
> ## and the *Quasi*poisson's dispersion
> sigma(glm.qD93 <- update(glm.D93, family = quasipoisson()))
[1] 1.13238
> sigma (glm.qD93)^2 # 1.282285 is close, but not the same
[1] 1.282285
> summary(glm.qD93)$dispersion # == 1.2933
[1] 1.2933
> 
> ## -- Multivariate lm() "mlm" -----------
> utils::example("SSD", echo=FALSE)
> sigma(mlmfit) # is the same as {but more efficient than}
   deg0NA    deg4NA    deg8NA    deg0NP    deg4NP    deg8NP 
 56.92100  86.02325  78.99367  88.54377 109.54451 116.79041 
> sqrt(diag(estVar(mlmfit)))
   deg0NA    deg4NA    deg8NA    deg0NP    deg4NP    deg8NP 
 56.92100  86.02325  78.99367  88.54377 109.54451 116.79041 
> ## Don't show: 
> stopifnot(all.equal(sigma(mlmfit), sqrt(diag(estVar(mlmfit)))))
> ## End(Don't show)
> 
> 
> 
> cleanEx()
> nameEx("simulate")
> ### * simulate
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: simulate
> ### Title: Simulate Responses
> ### Aliases: simulate
> ### Keywords: models datagen
> 
> ### ** Examples
> 
> x <- 1:5
> mod1 <- lm(c(1:3, 7, 6) ~ x)
> S1 <- simulate(mod1, nsim = 4)
> ## repeat the simulation:
> .Random.seed <- attr(S1, "seed")
> identical(S1, simulate(mod1, nsim = 4))
[1] TRUE
> 
> S2 <- simulate(mod1, nsim = 200, seed = 101)
> rowMeans(S2) # should be about the same as
        1         2         3         4         5 
0.6885691 2.2329771 3.7790352 5.2775859 6.8131451 
> fitted(mod1)
  1   2   3   4   5 
0.8 2.3 3.8 5.3 6.8 
> 
> ## repeat identically:
> (sseed <- attr(S2, "seed")) # seed; RNGkind as attribute
[1] 101
attr(,"kind")
attr(,"kind")[[1]]
[1] "Mersenne-Twister"

attr(,"kind")[[2]]
[1] "Inversion"

attr(,"kind")[[3]]
[1] "Rejection"

> stopifnot(identical(S2, simulate(mod1, nsim = 200, seed = sseed)))
> 
> ## To be sure about the proper RNGkind, e.g., after
> RNGversion("2.7.0")
Warning in RNGkind("Mersenne-Twister", "Inversion", "Rounding") :
  non-uniform 'Rounding' sampler used
> ## first set the RNG kind, then simulate
> do.call(RNGkind, attr(sseed, "kind"))
> identical(S2, simulate(mod1, nsim = 200, seed = sseed))
[1] TRUE
> 
> ## Binomial GLM examples
> yb1 <- matrix(c(4, 4, 5, 7, 8, 6, 6, 5, 3, 2), ncol = 2)
> modb1 <- glm(yb1 ~ x, family = binomial)
> S3 <- simulate(modb1, nsim = 4)
> # each column of S3 is a two-column matrix.
> 
> x2 <- sort(runif(100))
> yb2 <- rbinom(100, prob = plogis(2*(x2-1)), size = 1)
> yb2 <- factor(1 + yb2, labels = c("failure", "success"))
> modb2 <- glm(yb2 ~ x2, family = binomial)
> S4 <- simulate(modb2, nsim = 4)
> # each column of S4 is a factor
> 
> 
> 
> cleanEx()
> nameEx("smooth")
> ### * smooth
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: smooth
> ### Title: Tukey's (Running Median) Smoothing
> ### Aliases: smooth
> ### Keywords: robust smooth
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## see also   demo(smooth) !
> 
> x1 <- c(4, 1, 3, 6, 6, 4, 1, 6, 2, 4, 2) # very artificial
> (x3R <- smooth(x1, "3R")) # 2 iterations of "3"
3R Tukey smoother resulting from  smooth(x = x1, kind = "3R") 
 used 2 iterations
 [1] 3 3 3 6 6 4 4 4 2 2 2
> smooth(x3R, kind = "S")
S Tukey smoother resulting from  smooth(x = x3R, kind = "S") 
 changed
 [1] 3 3 3 3 4 4 4 4 2 2 2
> 
> sm.3RS <- function(x, ...)
+    smooth(smooth(x, "3R", ...), "S", ...)
> 
> y <- c(1, 1, 19:1)
> plot(y, main = "misbehaviour of \"3RSR\"", col.main = 3)
> lines(sm.3RS(y))
> lines(smooth(y))
> lines(smooth(y, "3RSR"), col = 3, lwd = 2)  # the horror
> 
> x <- c(8:10, 10, 0, 0, 9, 9)
> plot(x, main = "breakdown of  3R  and  S  and hence  3RSS")
> matlines(cbind(smooth(x, "3R"), smooth(x, "S"), smooth(x, "3RSS"), smooth(x)))
> 
> presidents[is.na(presidents)] <- 0 # silly
> summary(sm3 <- smooth(presidents, "3R"))
3R Tukey smoother resulting from
 smooth(x = presidents, kind = "3R") ;  n = 120 
 used 4 iterations
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
    0.0    44.0    57.0    54.2    71.0    82.0 
> summary(sm2 <- smooth(presidents,"3RSS"))
3RSS Tukey smoother resulting from
 smooth(x = presidents, kind = "3RSS") ;  n = 120 
 used 5 iterations
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
   0.00   44.00   57.00   55.45   69.00   82.00 
> summary(sm  <- smooth(presidents))
3RS3R Tukey smoother resulting from
 smooth(x = presidents) ;  n = 120 
 used 7 iterations
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  24.00   44.00   57.00   55.88   69.00   82.00 
> 
> all.equal(c(sm2), c(smooth(smooth(sm3, "S"), "S")))  # 3RSS  === 3R S S
[1] TRUE
> all.equal(c(sm),  c(smooth(smooth(sm3, "S"), "3R"))) # 3RS3R === 3R S 3R
[1] TRUE
> 
> plot(presidents, main = "smooth(presidents0, *) :  3R and default 3RS3R")
> lines(sm3, col = 3, lwd = 1.5)
> lines(sm, col = 2, lwd = 1.25)
> 
> 
> 
> cleanEx()
> nameEx("smooth.spline")
> ### * smooth.spline
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: smooth.spline
> ### Title: Fit a Smoothing Spline
> ### Aliases: smooth.spline .nknots.smspl
> ### Keywords: smooth
> 
> ### ** Examples
> 
> require(graphics)
> plot(dist ~ speed, data = cars, main = "data(cars)  &  smoothing splines")
> cars.spl <- with(cars, smooth.spline(speed, dist))
> cars.spl
Call:
smooth.spline(x = speed, y = dist)

Smoothing Parameter  spar= 0.7801305  lambda= 0.1112206 (11 iterations)
Equivalent Degrees of Freedom (Df): 2.635278
Penalized Criterion (RSS): 4187.776
GCV: 244.1044
> ## This example has duplicate points, so avoid cv = TRUE
> ## Don't show: 
>   stopifnot(cars.spl $ w == table(cars$speed)) # weights = multiplicities
>   utils::str(cars.spl, digits.d = 5, vec.len = 6)
List of 21
 $ x         : num [1:19] 4 7 8 9 10 11 12 13 14 15 16 17 18 19 20 ...
 $ y         : num [1:19] 1.6578 11.6829 15.0644 18.4823 21.9471 25.4656 29.0505 32.7076 ...
 $ w         : num [1:19] 2 2 1 1 3 2 4 4 4 3 2 3 4 3 5 ...
 $ yin       : num [1:19] 6 13 16 10 26 22.5 21.5 35 ...
 $ tol       : num 7e-06
 $ data      :List of 3
  ..$ x: num [1:50] 4 4 7 7 8 9 10 10 10 11 11 12 12 12 12 ...
  ..$ y: num [1:50] 2 10 4 22 16 10 18 26 34 17 28 14 20 24 28 ...
  ..$ w: num 1
 $ no.weights: logi TRUE
 $ n         : int 50
 $ lev       : num [1:19] 0.399342 0.179105 0.069771 0.055561 0.136721 0.077539 0.137252 0.126354 ...
 $ cv        : logi FALSE
 $ cv.crit   : num 244.1
 $ pen.crit  : num 4187.8
 $ crit      : num 244.1
 $ df        : num 2.6353
 $ spar      : num 0.78013
 $ ratio     : num 6.576e-05
 $ lambda    : num 0.11122
 $ iparms    : Named int [1:5] 1 0 11 0 NA
  ..- attr(*, "names")= chr [1:5] "icrit" "ispar" "iter" "" "errorI"
 $ auxM      : NULL
 $ fit       :List of 5
  ..$ knot : num [1:25] 0 0 0 0 0.14286 0.19048 0.2381 0.28571 ...
  ..$ nk   : int 21
  ..$ min  : num 4
  ..$ range: num 21
  ..$ coef : num [1:21] 1.6578 4.9869 9.4256 15.0584 18.4743 21.9384 25.4544 29.0377 ...
  ..- attr(*, "class")= chr "smooth.spline.fit"
 $ call      : language smooth.spline(x = speed, y = dist)
 - attr(*, "class")= chr "smooth.spline"
>   cars.spl$fit
$knot
 [1] 0.0000000 0.0000000 0.0000000 0.0000000 0.1428571 0.1904762 0.2380952
 [8] 0.2857143 0.3333333 0.3809524 0.4285714 0.4761905 0.5238095 0.5714286
[15] 0.6190476 0.6666667 0.7142857 0.7619048 0.8571429 0.9047619 0.9523810
[22] 1.0000000 1.0000000 1.0000000 1.0000000

$nk
[1] 21

$min
[1] 4

$range
[1] 21

$coef
 [1]  1.657809  4.986889  9.425578 15.058364 18.474307 21.938439 25.454405
 [8] 29.037679 32.697985 36.415692 40.180057 44.035086 48.004725 52.097325
[15] 56.299736 62.096055 68.215320 74.524063 79.313459 82.506943 84.103688

attr(,"class")
[1] "smooth.spline.fit"
> ## End(Don't show)
> lines(cars.spl, col = "blue")
> ss10 <- smooth.spline(cars[,"speed"], cars[,"dist"], df = 10)
> lines(ss10, lty = 2, col = "red")
> legend(5,120,c(paste("default [C.V.] => df =",round(cars.spl$df,1)),
+                "s( * , df = 10)"), col = c("blue","red"), lty = 1:2,
+        bg = 'bisque')
> 
> 
> ## Residual (Tukey Anscombe) plot:
> plot(residuals(cars.spl) ~ fitted(cars.spl))
> abline(h = 0, col = "gray")
> 
> ## consistency check:
> stopifnot(all.equal(cars$dist,
+                     fitted(cars.spl) + residuals(cars.spl)))
> ## The chosen inner knots in original x-scale :
> with(cars.spl$fit, min + range * knot[-c(1:3, nk+1 +1:3)]) # == unique(cars$speed)
 [1]  4  7  8  9 10 11 12 13 14 15 16 17 18 19 20 22 23 24 25
> 
> ## Visualize the behavior of  .nknots.smspl()
> nKnots <- Vectorize(.nknots.smspl) ; c.. <- adjustcolor("gray20",.5)
> curve(nKnots, 1, 250, n=250)
> abline(0,1, lty=2, col=c..); text(90,90,"y = x", col=c.., adj=-.25)
> abline(h=100,lty=2); abline(v=200, lty=2)
> 
> n <- c(1:799, seq(800, 3490, by=10), seq(3500, 10000, by = 50))
> plot(n, nKnots(n), type="l", main = "Vectorize(.nknots.smspl) (n)")
> abline(0,1, lty=2, col=c..); text(180,180,"y = x", col=c..)
> n0 <- c(50, 200, 800, 3200); c0 <- adjustcolor("blue3", .5)
> lines(n0, nKnots(n0), type="h", col=c0)
> axis(1, at=n0, line=-2, col.ticks=c0, col=NA, col.axis=c0)
> axis(4, at=.nknots.smspl(10000), line=-.5, col=c..,col.axis=c.., las=1)
> 
> ##-- artificial example
> y18 <- c(1:3, 5, 4, 7:3, 2*(2:5), rep(10, 4))
> xx  <- seq(1, length(y18), length.out = 201)
> (s2   <- smooth.spline(y18)) # GCV
Call:
smooth.spline(x = y18)

Smoothing Parameter  spar= 0.3928105  lambda= 9.672776e-05 (13 iterations)
Equivalent Degrees of Freedom (Df): 8.494168
Penalized Criterion (RSS): 3.59204
GCV: 0.7155391
> (s02  <- smooth.spline(y18, spar = 0.2))
Call:
smooth.spline(x = y18, spar = 0.2)

Smoothing Parameter  spar= 0.2  lambda= 3.911187e-06
Equivalent Degrees of Freedom (Df): 15.259
Penalized Criterion (RSS): 0.4973656
GCV: 1.191602
> (s02. <- smooth.spline(y18, spar = 0.2, cv = NA))
Call:
smooth.spline(x = y18, spar = 0.2, cv = NA)

Smoothing Parameter  spar= 0.2  lambda= 3.911187e-06
Equivalent Degrees of Freedom (Df): NA
Penalized Criterion (RSS): 0.4973656
> plot(y18, main = deparse(s2$call), col.main = 2)
> lines(s2, col = "gray"); lines(predict(s2, xx), col = 2)
> lines(predict(s02, xx), col = 3); mtext(deparse(s02$call), col = 3)
> 
> ## Specifying 'lambda' instead of usual spar :
> (s2. <- smooth.spline(y18, lambda = s2$lambda, tol = s2$tol))
Call:
smooth.spline(x = y18, lambda = s2$lambda, tol = s2$tol)

Smoothing Parameter  spar= NA  lambda= 9.672776e-05
Equivalent Degrees of Freedom (Df): 8.494168
Penalized Criterion (RSS): 3.59204
GCV: 0.7155391
> 
> ## Don't show: 
> stopifnot(identical(
+     with(s2$fit, min + range * knot[-c(1:3, nk+1+1:3)]),
+     as.numeric(1:18)),
+     with(cars.spl$fit, min + range * knot[-c(1:3, nk+1+1:3)]) == unique(cars$speed))
> 
> nD <- c("spar", "ratio", "iparms", "call"); nn <- setdiff(names(s2), nD)
> stopifnot(all.equal(s2[nn], s2.[nn], tolerance = 7e-7), # seen 6.86e-8
+           all.equal(predict(s02 , xx),
+ 		    predict(s02., xx), tolerance = 1e-15))
> ## End(Don't show)
> 
> 
> cleanEx()
> nameEx("smoothEnds")
> ### * smoothEnds
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: smoothEnds
> ### Title: End Points Smoothing (for Running Medians)
> ### Aliases: smoothEnds
> ### Keywords: smooth robust
> 
> ### ** Examples
> 
> require(graphics)
> 
> y <- ys <- (-20:20)^2
> y [c(1,10,21,41)] <-  c(100, 30, 400, 470)
> s7k <- runmed(y, 7, endrule = "keep")
> s7. <- runmed(y, 7, endrule = "const")
> s7m <- runmed(y, 7)
> col3 <- c("midnightblue","blue","steelblue")
> plot(y, main = "Running Medians -- runmed(*, k=7, endrule = X)")
> lines(ys, col = "light gray")
> matlines(cbind(s7k, s7.,s7m), lwd = 1.5, lty = 1, col = col3)
> eRules <- c("keep","constant","median")
> legend("topleft", paste("endrule", eRules, sep = " = "),
+        col = col3, lwd = 1.5, lty = 1, bty = "n")
> 
> stopifnot(identical(s7m, smoothEnds(s7k, 7)))
> 
> ## With missing values (for R >= 3.6.1):
> yN <- y; yN[c(2,40)] <- NA
> rN <- sapply(eRules, function(R) runmed(yN, 7, endrule=R))
> matlines(rN, type = "b", pch = 4, lwd = 3, lty=2,
+          col = adjustcolor(c("red", "orange4", "orange1"), 0.5))
> yN[c(1, 20:21)] <- NA # additionally
> rN. <- sapply(eRules, function(R) runmed(yN, 7, endrule=R))
> head(rN., 4); tail(rN.) # more NA's too, still not *so* many:
     keep constant median
[1,]   NA      256    392
[2,]   NA      256    324
[3,]  324      256    256
[4,]  256      256    256
      keep constant median
[36,]  225      225    225
[37,]  256      256    256
[38,]  289      289    289
[39,]  324      289    289
[40,]   NA      289    397
[41,]  470      289    470
> stopifnot(exprs = {
+    !anyNA(rN[,2:3])
+    identical(which(is.na(rN[,"keep"])), c(2L, 40L))
+    identical(which(is.na(rN.), arr.ind=TRUE, useNames=FALSE),
+              cbind(c(1:2,40L), 1L))
+    identical(rN.[38:41, "median"], c(289,289, 397, 470))
+ })
> 
> 
> 
> cleanEx()
> nameEx("sortedXyData")
> ### * sortedXyData
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: sortedXyData
> ### Title: Create a 'sortedXyData' Object
> ### Aliases: sortedXyData sortedXyData.default
> ### Keywords: manip
> 
> ### ** Examples
> 
> DNase.2 <- DNase[ DNase$Run == "2", ]
> sortedXyData( expression(log(conc)), expression(density), DNase.2 )
           x      y
1 -3.0194489 0.0475
2 -1.6331544 0.1300
3 -0.9400073 0.2160
4 -0.2468601 0.3920
5  0.4462871 0.6765
6  1.1394343 1.0970
7  1.8325815 1.5400
8  2.5257286 1.9230
> 
> 
> 
> cleanEx()
> nameEx("spec.ar")
> ### * spec.ar
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: spec.ar
> ### Title: Estimate Spectral Density of a Time Series from AR Fit
> ### Aliases: spec.ar
> ### Keywords: ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> spec.ar(lh)
> 
> spec.ar(ldeaths)
> spec.ar(ldeaths, method = "burg")
> 
> spec.ar(log(lynx))
> spec.ar(log(lynx), method = "burg", add = TRUE, col = "purple")
> spec.ar(log(lynx), method = "mle", add = TRUE, col = "forest green")
> spec.ar(log(lynx), method = "ols", add = TRUE, col = "blue")
> 
> 
> 
> cleanEx()
> nameEx("spec.pgram")
> ### * spec.pgram
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: spec.pgram
> ### Title: Estimate Spectral Density of a Time Series by a Smoothed
> ###   Periodogram
> ### Aliases: spec.pgram
> ### Keywords: ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## Examples from Venables & Ripley
> spectrum(ldeaths)
> spectrum(ldeaths, spans = c(3,5))
> spectrum(ldeaths, spans = c(5,7))
> spectrum(mdeaths, spans = c(3,3))
> spectrum(fdeaths, spans = c(3,3))
> 
> ## bivariate example
> mfdeaths.spc <- spec.pgram(ts.union(mdeaths, fdeaths), spans = c(3,3))
> # plots marginal spectra: now plot coherency and phase
> plot(mfdeaths.spc, plot.type = "coherency")
> plot(mfdeaths.spc, plot.type = "phase")
> 
> ## now impose a lack of alignment
> mfdeaths.spc <- spec.pgram(ts.intersect(mdeaths, lag(fdeaths, 4)),
+    spans = c(3,3), plot = FALSE)
> plot(mfdeaths.spc, plot.type = "coherency")
> plot(mfdeaths.spc, plot.type = "phase")
> 
> stocks.spc <- spectrum(EuStockMarkets, kernel("daniell", c(30,50)),
+                        plot = FALSE)
> plot(stocks.spc, plot.type = "marginal") # the default type
> plot(stocks.spc, plot.type = "coherency")
> plot(stocks.spc, plot.type = "phase")
> 
> sales.spc <- spectrum(ts.union(BJsales, BJsales.lead),
+                       kernel("modified.daniell", c(5,7)))
> plot(sales.spc, plot.type = "coherency")
> plot(sales.spc, plot.type = "phase")
> 
> 
> 
> cleanEx()
> nameEx("spectrum")
> ### * spectrum
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: spectrum
> ### Title: Spectral Density Estimation
> ### Aliases: spectrum spec
> ### Keywords: ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> ## Examples from Venables & Ripley
> ## spec.pgram
> par(mfrow = c(2,2))
> spectrum(lh)
> spectrum(lh, spans = 3)
> spectrum(lh, spans = c(3,3))
> spectrum(lh, spans = c(3,5))
> 
> spectrum(ldeaths)
> spectrum(ldeaths, spans = c(3,3))
> spectrum(ldeaths, spans = c(3,5))
> spectrum(ldeaths, spans = c(5,7))
> spectrum(ldeaths, spans = c(5,7), log = "dB", ci = 0.8)
> 
> # for multivariate examples see the help for spec.pgram
> 
> ## spec.ar
> spectrum(lh, method = "ar")
> spectrum(ldeaths, method = "ar")
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("splinefun")
> ### * splinefun
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: splinefun
> ### Title: Interpolating Splines
> ### Aliases: spline splinefun splinefunH
> ### Keywords: math dplot
> 
> ### ** Examples
> 
> require(graphics)
> 
> op <- par(mfrow = c(2,1), mgp = c(2,.8,0), mar = 0.1+c(3,3,3,1))
> n <- 9
> x <- 1:n
> y <- rnorm(n)
> plot(x, y, main = paste("spline[fun](.) through", n, "points"))
> lines(spline(x, y))
> lines(spline(x, y, n = 201), col = 2)
> 
> y <- (x-6)^2
> plot(x, y, main = "spline(.) -- 3 methods")
> lines(spline(x, y, n = 201), col = 2)
> lines(spline(x, y, n = 201, method = "natural"), col = 3)
> lines(spline(x, y, n = 201, method = "periodic"), col = 4)
Warning in spline(x, y, n = 201, method = "periodic") :
  spline: first and last y values differ - using y[1] for both
> legend(6, 25, c("fmm","natural","periodic"), col = 2:4, lty = 1)
> 
> y <- sin((x-0.5)*pi)
> f <- splinefun(x, y)
> ls(envir = environment(f))
[1] "z"
> splinecoef <- get("z", envir = environment(f))
> curve(f(x), 1, 10, col = "green", lwd = 1.5)
> points(splinecoef, col = "purple", cex = 2)
> curve(f(x, deriv = 1), 1, 10, col = 2, lwd = 1.5)
> curve(f(x, deriv = 2), 1, 10, col = 2, lwd = 1.5, n = 401)
> curve(f(x, deriv = 3), 1, 10, col = 2, lwd = 1.5, n = 401)
> par(op)
> 
> ## Manual spline evaluation --- demo the coefficients :
> .x <- splinecoef$x
> u <- seq(3, 6, by = 0.25)
> (ii <- findInterval(u, .x))
 [1] 3 3 3 3 4 4 4 4 5 5 5 5 6
> dx <- u - .x[ii]
> f.u <- with(splinecoef,
+             y[ii] + dx*(b[ii] + dx*(c[ii] + dx* d[ii])))
> stopifnot(all.equal(f(u), f.u))
> 
> ## An example with ties (non-unique  x values):
> set.seed(1); x <- round(rnorm(30), 1); y <- sin(pi * x) + rnorm(30)/10
> plot(x, y, main = "spline(x,y)  when x has ties")
> lines(spline(x, y, n = 201), col = 2)
Warning in regularize.values(x, y, ties, missing(ties)) :
  collapsing to unique 'x' values
> ## visualizes the non-unique ones:
> tx <- table(x); mx <- as.numeric(names(tx[tx > 1]))
> ry <- matrix(unlist(tapply(y, match(x, mx), range, simplify = FALSE)),
+              ncol = 2, byrow = TRUE)
> segments(mx, ry[, 1], mx, ry[, 2], col = "blue", lwd = 2)
> 
> ## Another example with sorted x, but ties:
> set.seed(8); x <- sort(round(rnorm(30), 1)); y <- round(sin(pi * x) + rnorm(30)/10, 3)
> summary(diff(x) == 0) # -> 7 duplicated x-values
   Mode   FALSE    TRUE 
logical      22       7 
> str(spline(x, y, n = 201, ties="ordered")) # all '$y' entries are NaN
List of 2
 $ x: num [1:201] -3 -2.98 -2.95 -2.92 -2.9 ...
 $ y: num [1:201] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN ...
> ## The default (ties=mean) is ok, but most efficient to use instead is
> sxyo <- spline(x, y, n = 201, ties= list("ordered", mean))
> sapply(sxyo, summary)# all fine now
            x           y
Min.    -3.00 -1.07800000
1st Qu. -1.75 -0.57050000
Median  -0.50 -0.13613265
Mean    -0.50 -0.08208311
3rd Qu.  0.75  0.50611122
Max.     2.00  1.03072752
> plot(x, y, main = "spline(x,y, ties=list(\"ordered\", mean))  for when x has ties")
> lines(sxyo, col="blue")
> 
> ## An example of monotone interpolation
> n <- 20
> set.seed(11)
> x. <- sort(runif(n)) ; y. <- cumsum(abs(rnorm(n)))
> plot(x., y.)
> curve(splinefun(x., y.)(x), add = TRUE, col = 2, n = 1001)
> curve(splinefun(x., y., method = "monoH.FC")(x), add = TRUE, col = 3, n = 1001)
> curve(splinefun(x., y., method = "hyman")   (x), add = TRUE, col = 4, n = 1001)
> legend("topleft",
+        paste0("splinefun( \"", c("fmm", "monoH.FC", "hyman"), "\" )"),
+        col = 2:4, lty = 1, bty = "n")
> 
> ## and one from Fritsch and Carlson (1980), Dougherty et al (1989)
> x. <- c(7.09, 8.09, 8.19, 8.7, 9.2, 10, 12, 15, 20)
> f <- c(0, 2.76429e-5, 4.37498e-2, 0.169183, 0.469428, 0.943740,
+        0.998636, 0.999919, 0.999994)
> s0 <- splinefun(x., f)
> s1 <- splinefun(x., f, method = "monoH.FC")
> s2 <- splinefun(x., f, method = "hyman")
> plot(x., f, ylim = c(-0.2, 1.2))
> curve(s0(x), add = TRUE, col = 2, n = 1001) -> m0
> curve(s1(x), add = TRUE, col = 3, n = 1001)
> curve(s2(x), add = TRUE, col = 4, n = 1001)
> legend("right",
+        paste0("splinefun( \"", c("fmm", "monoH.FC", "hyman"), "\" )"),
+        col = 2:4, lty = 1, bty = "n")
> 
> ## they seem identical, but are not quite:
> xx <- m0$x
> plot(xx, s1(xx) - s2(xx), type = "l",  col = 2, lwd = 2,
+      main = "Difference   monoH.FC - hyman"); abline(h = 0, lty = 3)
> 
> x <- xx[xx < 10.2] ## full range: x <- xx .. does not show enough
> ccol <- adjustcolor(2:4, 0.8)
> matplot(x, cbind(s0(x, deriv = 2), s1(x, deriv = 2), s2(x, deriv = 2))^2,
+         lwd = 2, col = ccol, type = "l", ylab = quote({{f*second}(x)}^2),
+         main = expression({{f*second}(x)}^2 ~" for the three 'splines'"))
> legend("topright",
+        paste0("splinefun( \"", c("fmm", "monoH.FC", "hyman"), "\" )"),
+        lwd = 2, col  =  ccol, lty = 1:3, bty = "n")
> ## --> "hyman" has slightly smaller  Integral f''(x)^2 dx  than "FC",
> ## here, and both are 'much worse' than the regular fmm spline.
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("stat.anova")
> ### * stat.anova
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: stat.anova
> ### Title: GLM Anova Statistics
> ### Aliases: stat.anova
> ### Keywords: regression models
> 
> ### ** Examples
> 
> ##-- Continued from '?glm':
> ## Don't show: 
> utils::example("glm", echo = FALSE)
> ## End(Don't show)
> print(ag <- anova(glm.D93))
Analysis of Deviance Table

Model: poisson, link: log

Response: counts

Terms added sequentially (first to last)


          Df Deviance Resid. Df Resid. Dev
NULL                          8    10.5814
outcome    2   5.4523         6     5.1291
treatment  2   0.0000         4     5.1291
> stat.anova(ag$table, test = "Cp",
+            scale = sum(resid(glm.D93, "pearson")^2)/4,
+            df.scale = 4, n = 9)
     table Cp
> 
> 
> 
> cleanEx()
> nameEx("step")
> ### * step
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: step
> ### Title: Choose a model by AIC in a Stepwise Algorithm
> ### Aliases: step
> ### Keywords: models
> 
> ### ** Examples
> 
> 
> cleanEx()
> nameEx("stepfun")
> ### * stepfun
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: stepfun
> ### Title: Step Functions - Creation and Class
> ### Aliases: stepfun is.stepfun as.stepfun print.stepfun summary.stepfun
> ###   knots
> ### Keywords: dplot
> 
> ### ** Examples
> 
> y0 <- c(1., 2., 4., 3.)
> sfun0  <- stepfun(1:3, y0, f = 0)
> sfun.2 <- stepfun(1:3, y0, f = 0.2)
> sfun1  <- stepfun(1:3, y0, f = 1)
> sfun1c <- stepfun(1:3, y0, right = TRUE) # hence f=1
> sfun0
Step function
Call: stepfun(1:3, y0, f = 0)
 x[1:3] =      1,      2,      3
4 plateau levels =      1,      2,      4,      3
> summary(sfun0)
Step function with continuity 'f'= 0 ,  3 knots at
[1] 1 2 3
  and	4 plateau levels (y) at
[1] 1 2 4 3
> summary(sfun.2)
Step function with continuity 'f'= 0.2 ,  3 knots at
[1] 1 2 3
  and	4 plateau levels (y) at
[1] 1 2 4 3
> 
> ## look at the internal structure:
> unclass(sfun0)
function (v) 
.approxfun(x, y, v, method, yleft, yright, f, na.rm)
<bytecode: 0x4127218>
<environment: 0x8c9c5d8>
attr(,"call")
stepfun(1:3, y0, f = 0)
> ls(envir = environment(sfun0))
[1] "f"      "method" "na.rm"  "x"      "y"      "yleft"  "yright"
> 
> x0 <- seq(0.5, 3.5, by = 0.25)
> rbind(x = x0, f.f0 = sfun0(x0), f.f02 = sfun.2(x0),
+       f.f1 = sfun1(x0), f.f1c = sfun1c(x0))
      [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13]
x      0.5 0.75    1 1.25  1.5 1.75    2 2.25  2.5  2.75     3  3.25   3.5
f.f0   1.0 1.00    2 2.00  2.0 2.00    4 4.00  4.0  4.00     3  3.00   3.0
f.f02  1.0 1.00    2 2.40  2.4 2.40    4 3.80  3.8  3.80     3  3.00   3.0
f.f1   1.0 1.00    2 4.00  4.0 4.00    4 3.00  3.0  3.00     3  3.00   3.0
f.f1c  1.0 1.00    1 2.00  2.0 2.00    2 4.00  4.0  4.00     4  3.00   3.0
> ## Identities :
> stopifnot(identical(y0[-1], sfun0 (1:3)), # right = FALSE
+           identical(y0[-4], sfun1c(1:3))) # right = TRUE
> 
> 
> 
> cleanEx()
> nameEx("stl")
> ### * stl
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: stl
> ### Title: Seasonal Decomposition of Time Series by Loess
> ### Aliases: stl
> ### Keywords: ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> plot(stl(nottem, "per"))
> plot(stl(nottem, s.window = 7, t.window = 50, t.jump = 1))
> 
> plot(stllc <- stl(log(co2), s.window = 21))
> summary(stllc)
 Call:
 stl(x = log(co2), s.window = 21)

 Time.series components:
    seasonal                trend            remainder            
 Min.   :-0.009939103   Min.   :5.753541   Min.   :-0.0022554051  
 1st Qu.:-0.004536535   1st Qu.:5.778556   1st Qu.:-0.0004586796  
 Median : 0.000877761   Median :5.815125   Median :-0.0000088674  
 Mean   :-0.000001304   Mean   :5.819267   Mean   :-0.0000019655  
 3rd Qu.: 0.004997747   3rd Qu.:5.859806   3rd Qu.: 0.0004023465  
 Max.   : 0.009114691   Max.   :5.898750   Max.   : 0.0019396260  
 IQR:
     STL.seasonal STL.trend STL.remainder data    
     0.009534     0.081250  0.000861      0.079370
   %  12.0        102.4       1.1         100.0   

 Weights: all == 1

 Other components: List of 5
 $ win  : Named num [1:3] 21 21 13
 $ deg  : Named int [1:3] 0 1 1
 $ jump : Named num [1:3] 3 3 2
 $ inner: int 2
 $ outer: int 0
> ## linear trend, strict period.
> plot(stl(log(co2), s.window = "per", t.window = 1000))
> 
> ## Two STL plotted side by side :
>         stmd <- stl(mdeaths, s.window = "per") # non-robust
> summary(stmR <- stl(mdeaths, s.window = "per", robust = TRUE))
 Call:
 stl(x = mdeaths, s.window = "per", robust = TRUE)

 Time.series components:
    seasonal             trend            remainder        
 Min.   :-446.8302   Min.   :1318.650   Min.   :-314.5835  
 1st Qu.:-301.5726   1st Qu.:1432.208   1st Qu.: -32.5392  
 Median : -79.0561   Median :1448.891   Median :   5.7943  
 Mean   :   0.0000   Mean   :1472.880   Mean   :  23.0646  
 3rd Qu.: 304.5673   3rd Qu.:1548.974   3rd Qu.:  47.5134  
 Max.   : 544.7904   Max.   :1615.535   Max.   : 872.1992  
 IQR:
     STL.seasonal STL.trend STL.remainder data  
     606.14       116.77     80.05        707.75
   %  85.6         16.5      11.3         100.0 

 Weights:
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
 0.0000  0.5594  0.9452  0.7312  0.9853  1.0000 

 Other components: List of 5
 $ win  : Named num [1:3] 721 19 13
 $ deg  : Named int [1:3] 0 1 1
 $ jump : Named num [1:3] 73 2 2
 $ inner: int 1
 $ outer: int 15
> op <- par(mar = c(0, 4, 0, 3), oma = c(5, 0, 4, 0), mfcol = c(4, 2))
> plot(stmd, set.pars = NULL, labels  =  NULL,
+      main = "stl(mdeaths, s.w = \"per\",  robust = FALSE / TRUE )")
> plot(stmR, set.pars = NULL)
> # mark the 'outliers' :
> (iO <- which(stmR $ weights  < 1e-8)) # 10 were considered outliers
 [1] 24 26 27 28 36 37 50 52 59 61
> sts <- stmR$time.series
> points(time(sts)[iO], 0.8* sts[,"remainder"][iO], pch = 4, col = "red")
> par(op)   # reset
> 
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("summary.aov")
> ### * summary.aov
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: summary.aov
> ### Title: Summarize an Analysis of Variance Model
> ### Aliases: summary.aov summary.aovlist print.summary.aov
> ###   print.summary.aovlist
> ### Keywords: models regression
> 
> ### ** Examples
> 
> ## For a simple example see example(aov)
> 
> # Cochran and Cox (1957, p.164)
> # 3x3 factorial with ordered factors, each is average of 12.
> CC <- data.frame(
+     y = c(449, 413, 326, 409, 358, 291, 341, 278, 312)/12,
+     P = ordered(gl(3, 3)), N = ordered(gl(3, 1, 9))
+ )
> CC.aov <- aov(y ~ N * P, data = CC , weights = rep(12, 9))
> summary(CC.aov)
            Df Sum Sq Mean Sq
N            2 1016.7   508.3
P            2  917.4   458.7
N:P          4  399.3    99.8
> 
> # Split both main effects into linear and quadratic parts.
> summary(CC.aov, split = list(N = list(L = 1, Q = 2),
+                              P = list(L = 1, Q = 2)))
            Df Sum Sq Mean Sq
N            2 1016.7   508.3
  N: L       1 1012.5  1012.5
  N: Q       1    4.2     4.2
P            2  917.4   458.7
  P: L       1  917.3   917.3
  P: Q       1    0.0     0.0
N:P          4  399.3    99.8
  N:P: L.L   1  184.1   184.1
  N:P: Q.L   1  152.1   152.1
  N:P: L.Q   1   49.0    49.0
  N:P: Q.Q   1   14.1    14.1
> 
> # Split only the interaction
> summary(CC.aov, split = list("N:P" = list(L.L = 1, Q = 2:4)))
            Df Sum Sq Mean Sq
N            2 1016.7   508.3
P            2  917.4   458.7
N:P          4  399.3    99.8
  N:P: L.L   1  184.1   184.1
  N:P: Q     3  215.2    71.7
> 
> # split on just one var
> summary(CC.aov, split = list(P = list(lin = 1, quad = 2)))
            Df Sum Sq Mean Sq
N            2 1016.7   508.3
P            2  917.4   458.7
  P: lin     1  917.3   917.3
  P: quad    1    0.0     0.0
N:P          4  399.3    99.8
  N:P: lin   2  336.2   168.1
  N:P: quad  2   63.1    31.5
> summary(CC.aov, split = list(P = list(lin = 1, quad = 2)),
+         expand.split = FALSE)
            Df Sum Sq Mean Sq
N            2 1016.7   508.3
P            2  917.4   458.7
  P: lin     1  917.3   917.3
  P: quad    1    0.0     0.0
N:P          4  399.3    99.8
> 
> 
> cleanEx()
> nameEx("summary.glm")
> ### * summary.glm
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: summary.glm
> ### Title: Summarizing Generalized Linear Model Fits
> ### Aliases: summary.glm print.summary.glm
> ### Keywords: models regression
> 
> ### ** Examples
> 
> ## For examples see example(glm)
> 
> 
> 
> cleanEx()
> nameEx("summary.lm")
> ### * summary.lm
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: summary.lm
> ### Title: Summarizing Linear Model Fits
> ### Aliases: summary.lm summary.mlm print.summary.lm
> ### Keywords: regression models
> 
> ### ** Examples
> 
> ## Don't show: 
> utils::example("lm", echo = FALSE)
> ## End(Don't show)
> ##-- Continuing the  lm(.) example:
> coef(lm.D90)  # the bare coefficients
groupCtl groupTrt 
   5.032    4.661 
> sld90 <- summary(lm.D90 <- lm(weight ~ group -1))  # omitting intercept
> sld90

Call:
lm(formula = weight ~ group - 1)

Residuals:
    Min      1Q  Median      3Q     Max 
-1.0710 -0.4938  0.0685  0.2462  1.3690 

Coefficients:
         Estimate Std. Error t value Pr(>|t|)    
groupCtl   5.0320     0.2202   22.85 9.55e-15 ***
groupTrt   4.6610     0.2202   21.16 3.62e-14 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 0.6964 on 18 degrees of freedom
Multiple R-squared:  0.9818,	Adjusted R-squared:  0.9798 
F-statistic: 485.1 on 2 and 18 DF,  p-value: < 2.2e-16

> coef(sld90)  # much more
         Estimate Std. Error  t value     Pr(>|t|)
groupCtl    5.032  0.2202177 22.85012 9.547128e-15
groupTrt    4.661  0.2202177 21.16542 3.615345e-14
> 
> ## model with *aliased* coefficient:
> lm.D9. <- lm(weight ~ group + I(group != "Ctl"))
> Sm.D9. <- summary(lm.D9.)
> Sm.D9. #  shows the NA NA NA NA  line

Call:
lm(formula = weight ~ group + I(group != "Ctl"))

Residuals:
    Min      1Q  Median      3Q     Max 
-1.0710 -0.4938  0.0685  0.2462  1.3690 

Coefficients: (1 not defined because of singularities)
                      Estimate Std. Error t value Pr(>|t|)    
(Intercept)             5.0320     0.2202  22.850 9.55e-15 ***
groupTrt               -0.3710     0.3114  -1.191    0.249    
I(group != "Ctl")TRUE       NA         NA      NA       NA    
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 0.6964 on 18 degrees of freedom
Multiple R-squared:  0.07308,	Adjusted R-squared:  0.02158 
F-statistic: 1.419 on 1 and 18 DF,  p-value: 0.249

> stopifnot(length(cc <- coef(lm.D9.)) == 3, is.na(cc[3]),
+           dim(coef(Sm.D9.)) == c(2,4), Sm.D9.$df == c(2, 18, 3))
> 
> 
> 
> cleanEx()
> nameEx("summary.manova")
> ### * summary.manova
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: summary.manova
> ### Title: Summary Method for Multivariate Analysis of Variance
> ### Aliases: summary.manova print.summary.manova
> ### Keywords: models
> 
> ### ** Examples
> 
> 
> cleanEx()
> nameEx("summary.princomp")
> ### * summary.princomp
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: summary.princomp
> ### Title: Summary method for Principal Components Analysis
> ### Aliases: summary.princomp print.summary.princomp
> ### Keywords: multivariate
> 
> ### ** Examples
> 
> summary(pc.cr <- princomp(USArrests, cor = TRUE))
Importance of components:
                          Comp.1    Comp.2    Comp.3     Comp.4
Standard deviation     1.5748783 0.9948694 0.5971291 0.41644938
Proportion of Variance 0.6200604 0.2474413 0.0891408 0.04335752
Cumulative Proportion  0.6200604 0.8675017 0.9566425 1.00000000
> ## The signs of the loading columns are arbitrary
> print(summary(princomp(USArrests, cor = TRUE),
+               loadings = TRUE, cutoff = 0.2), digits = 2)
Importance of components:
                          Comp.1    Comp.2    Comp.3     Comp.4
Standard deviation     1.5748783 0.9948694 0.5971291 0.41644938
Proportion of Variance 0.6200604 0.2474413 0.0891408 0.04335752
Cumulative Proportion  0.6200604 0.8675017 0.9566425 1.00000000

Loadings:
         Comp.1 Comp.2 Comp.3 Comp.4
Murder    0.54   0.42   0.34   0.65 
Assault   0.58          0.27  -0.74 
UrbanPop  0.28  -0.87   0.38        
Rape      0.54         -0.82        
> 
> 
> 
> cleanEx()
> nameEx("supsmu")
> ### * supsmu
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: supsmu
> ### Title: Friedman's SuperSmoother
> ### Aliases: supsmu
> ### Keywords: smooth
> 
> ### ** Examples
> 
> require(graphics)
> 
> with(cars, {
+     plot(speed, dist)
+     lines(supsmu(speed, dist))
+     lines(supsmu(speed, dist, bass = 7), lty = 2)
+     })
> 
> 
> 
> cleanEx()
> nameEx("symnum")
> ### * symnum
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: symnum
> ### Title: Symbolic Number Coding
> ### Aliases: symnum
> ### Keywords: utilities character
> 
> ### ** Examples
> 
> ii <- setNames(0:8, 0:8)
> symnum(ii, cutpoints =  2*(0:4), symbols = c(".", "-", "+", "$"))
0 1 2 3 4 5 6 7 8 
. . . - - + + $ $ 
attr(,"legend")
[1] 0 ‘.’ 2 ‘-’ 4 ‘+’ 6 ‘$’ 8
> symnum(ii, cutpoints =  2*(0:4), symbols = c(".", "-", "+", "$"), show.max = TRUE)
0 1 2 3 4 5 6 7 8 
. . . - - + + $ 8 
attr(,"legend")
[1] 0 ‘.’ 2 ‘-’ 4 ‘+’ 6 ‘$’ 8
> 
> symnum(1:12 %% 3 == 0)  # --> "|" = TRUE, "." = FALSE  for logical
 [1] . . | . . | . . | . . |
> 
> ## Pascal's Triangle modulo 2 -- odd and even numbers:
> N <- 38
> pascal <- t(sapply(0:N, function(n) round(choose(n, 0:N - (N-n)%/%2))))
> rownames(pascal) <- rep("", 1+N) # <-- to improve "graphic"
> symnum(pascal %% 2, symbols = c(" ", "A"), numeric.x = FALSE)
                                                                              
                                       A                                      
                                     A A                                      
                                     A   A                                    
                                   A A A A                                    
                                   A       A                                  
                                 A A     A A                                  
                                 A   A   A   A                                
                               A A A A A A A A                                
                               A               A                              
                             A A             A A                              
                             A   A           A   A                            
                           A A A A         A A A A                            
                           A       A       A       A                          
                         A A     A A     A A     A A                          
                         A   A   A   A   A   A   A   A                        
                       A A A A A A A A A A A A A A A A                        
                       A                               A                      
                     A A                             A A                      
                     A   A                           A   A                    
                   A A A A                         A A A A                    
                   A       A                       A       A                  
                 A A     A A                     A A     A A                  
                 A   A   A   A                   A   A   A   A                
               A A A A A A A A                 A A A A A A A A                
               A               A               A               A              
             A A             A A             A A             A A              
             A   A           A   A           A   A           A   A            
           A A A A         A A A A         A A A A         A A A A            
           A       A       A       A       A       A       A       A          
         A A     A A     A A     A A     A A     A A     A A     A A          
         A   A   A   A   A   A   A   A   A   A   A   A   A   A   A   A        
       A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A        
       A                                                               A      
     A A                                                             A A      
     A   A                                                           A   A    
   A A A A                                                         A A A A    
   A       A                                                       A       A  
 A A     A A                                                     A A     A A  
 A   A   A   A                                                   A   A   A   A
> 
> ##-- Symbolic correlation matrices:
> symnum(cor(attitude), diag.lower.tri = FALSE)
           rt cm p l rs cr a
rating                      
complaints +                
privileges .  .             
learning   ,  .  .          
raises     .  ,  . ,        
critical             .      
advance          . . .      
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> symnum(cor(attitude), abbr.colnames = NULL)
                        
rating     1            
complaints + 1          
privileges . . 1        
learning   , . . 1      
raises     . , . , 1    
critical           . 1  
advance        . . .   1
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> symnum(cor(attitude), abbr.colnames = FALSE)
           rating complaints privileges learning raises critical advance
rating     1                                                            
complaints +      1                                                     
privileges .      .          1                                          
learning   ,      .          .          1                               
raises     .      ,          .          ,        1                      
critical                                         .      1               
advance                      .          .        .               1      
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> symnum(cor(attitude), abbr.colnames = 2)
           rt cm pr lr rs cr ad
rating     1                   
complaints +  1                
privileges .  .  1             
learning   ,  .  .  1          
raises     .  ,  .  ,  1       
critical               .  1    
advance          .  .  .     1 
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> 
> symnum(cor(rbind(1, rnorm(25), rnorm(25)^2)))
                                                       
 [1,] 1                                                
 [2,] + 1                                              
 [3,] .   1                                            
 [4,] .   B 1                                          
 [5,] + B     1                                        
 [6,] .   B B   1                                      
 [7,] , * . . *   1                                    
 [8,] . + . , + . B 1                                  
 [9,] . + . , * . B B 1                                
[10,] .   B B   B . . . 1                              
[11,]     B B . * . , , B 1                            
[12,] , B   . B   B + *   . 1                          
[13,] 1 + . . + . , . . .   , 1                        
[14,] , . * +   B       * +   , 1                      
[15,]   . * B . + , + , * B .   , 1                    
[16,] * B     B   + , ,     * * .   1                  
[17,] * B     B   + , ,     * * .   B 1                
[18,]   , , + , , * B * , + ,   . * . . 1              
[19,] . + , , + . B B B , + + . . + , , B 1            
[20,] + B     B   B + *   . B +   . B B , + 1          
[21,]   , , + , , * B B , + +   . * . . B B , 1        
[22,] . , , , + . B B B , + + . . + , , B B + B 1      
[23,] B , , . , , .   . , . , B +   + +     ,     1    
[24,] * , , . , , .     , . . * * . , ,     .     B 1  
[25,] B + . . + . , . . .   , B ,   * *   . +   . B B 1
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> symnum(cor(matrix(rexp(30, 1), 5, 18))) # <<-- PATTERN ! --
                                         
 [1,] 1                                  
 [2,] . 1                                
 [3,]     1                              
 [4,] . .   1                            
 [5,]   , .   1                          
 [6,]   ,     , 1                        
 [7,] 1 .   .     1                      
 [8,] . 1   . , , . 1                    
 [9,]     1   .       1                  
[10,] . .   1     . .   1                
[11,]   , .   1 ,   , .   1              
[12,]   ,     , 1   ,     , 1            
[13,] 1 .   .     1 .   .     1          
[14,] . 1   . , , . 1   . , , . 1        
[15,]     1   .       1   .       1      
[16,] . .   1     . .   1     . .   1    
[17,]   , .   1 ,   , .   1 ,   , .   1  
[18,]   ,     , 1   ,     , 1   ,     , 1
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> symnum(cm1 <- cor(matrix(rnorm(90) ,  5, 18))) # < White Noise SMALL n
                                         
 [1,] 1                                  
 [2,] . 1                                
 [3,] . . 1                              
 [4,] , ,   1                            
 [5,]   . ,   1                          
 [6,]   . *   * 1                        
 [7,] , .   . .   1                      
 [8,] , .   .       1                    
 [9,]   .   . . . . . 1                  
[10,] , .   .     . B . 1                
[11,] ,   + . + + ,   .   1              
[12,]   , +   + *   .   . , 1            
[13,] . +   +     ,   +   .   1          
[14,]       .   .   . + ,     , 1        
[15,]   .   .     .   . .     . + 1      
[16,] .   , .   .   . . . .         1    
[17,]   , +   , +       . . * .     . 1  
[18,]   . .   * , . . .   , ,     .   . 1
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> symnum(cm1, diag.lower.tri = FALSE)
                                        
 [1,]                                   
 [2,] .                                 
 [3,] . .                               
 [4,] , ,                               
 [5,]   . ,                             
 [6,]   . *   *                         
 [7,] , .   . .                         
 [8,] , .   .                           
 [9,]   .   . . . . .                   
[10,] , .   .     . B .                 
[11,] ,   + . + + ,   .                 
[12,]   , +   + *   .   . ,             
[13,] . +   +     ,   +   .             
[14,]       .   .   . + ,     ,         
[15,]   .   .     .   . .     . +       
[16,] .   , .   .   . . . .             
[17,]   , +   , +       . . * .     .   
[18,]   . .   * , . . .   , ,     .   . 
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> symnum(cm2 <- cor(matrix(rnorm(900), 50, 18))) # < White Noise "BIG" n
                                         
 [1,] 1                                  
 [2,]   1                                
 [3,]     1                              
 [4,]       1                            
 [5,]         1                          
 [6,]           1                        
 [7,]             1                      
 [8,]               1                    
 [9,]                 1                  
[10,]                   1                
[11,]                     1              
[12,]                       1            
[13,]               .     .   1          
[14,]                           1        
[15,]                             1      
[16,]                               1    
[17,]                                 1  
[18,]                                   1
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> symnum(cm2, lower.triangular = FALSE)
                                         
 [1,] 1                                  
 [2,]   1                                
 [3,]     1                              
 [4,]       1                            
 [5,]         1                          
 [6,]           1                        
 [7,]             1                      
 [8,]               1         .          
 [9,]                 1                  
[10,]                   1                
[11,]                     1   .          
[12,]                       1            
[13,]               .     .   1          
[14,]                           1        
[15,]                             1      
[16,]                               1    
[17,]                                 1  
[18,]                                   1
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1
> 
> ## NA's:
> Cm <- cor(matrix(rnorm(60),  10, 6)); Cm[c(3,6), 2] <- NA
> symnum(Cm, show.max = NULL)
               
[1,]           
[2,]           
[3,] . ?       
[4,] .   ,     
[5,]     .     
[6,] , ?       
attr(,"legend")
[1] 0 ‘ ’ 0.3 ‘.’ 0.6 ‘,’ 0.8 ‘+’ 0.9 ‘*’ 0.95 ‘B’ 1 \t    ## NA: ‘?’
> 
> ## Graphical P-values (aka "significance stars"):
> pval <- rev(sort(c(outer(1:6, 10^-(1:3)))))
> symp <- symnum(pval, corr = FALSE,
+                cutpoints = c(0,  .001,.01,.05, .1, 1),
+                symbols = c("***","**","*","."," "))
> noquote(cbind(P.val = format(pval), Signif = symp))
      P.val Signif
 [1,] 0.600       
 [2,] 0.500       
 [3,] 0.400       
 [4,] 0.300       
 [5,] 0.200       
 [6,] 0.100 .     
 [7,] 0.060 .     
 [8,] 0.050 *     
 [9,] 0.040 *     
[10,] 0.030 *     
[11,] 0.020 *     
[12,] 0.010 **    
[13,] 0.006 **    
[14,] 0.005 **    
[15,] 0.004 **    
[16,] 0.003 **    
[17,] 0.002 **    
[18,] 0.001 ***   
> 
> 
> 
> cleanEx()
> nameEx("t.test")
> ### * t.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: t.test
> ### Title: Student's t-Test
> ### Aliases: t.test t.test.default t.test.formula
> ### Keywords: htest
> 
> ### ** Examples
> 
> require(graphics)
> 
> t.test(1:10, y = c(7:20))      # P = .00001855

	Welch Two Sample t-test

data:  1:10 and c(7:20)
t = -5.4349, df = 21.982, p-value = 1.855e-05
alternative hypothesis: true difference in means is not equal to 0
95 percent confidence interval:
 -11.052802  -4.947198
sample estimates:
mean of x mean of y 
      5.5      13.5 

> t.test(1:10, y = c(7:20, 200)) # P = .1245    -- NOT significant anymore

	Welch Two Sample t-test

data:  1:10 and c(7:20, 200)
t = -1.6329, df = 14.165, p-value = 0.1245
alternative hypothesis: true difference in means is not equal to 0
95 percent confidence interval:
 -47.242900   6.376233
sample estimates:
mean of x mean of y 
  5.50000  25.93333 

> 
> ## Classical example: Student's sleep data
> plot(extra ~ group, data = sleep)
> ## Traditional interface
> with(sleep, t.test(extra[group == 1], extra[group == 2]))

	Welch Two Sample t-test

data:  extra[group == 1] and extra[group == 2]
t = -1.8608, df = 17.776, p-value = 0.07939
alternative hypothesis: true difference in means is not equal to 0
95 percent confidence interval:
 -3.3654832  0.2054832
sample estimates:
mean of x mean of y 
     0.75      2.33 

> 
> ## Formula interface
> t.test(extra ~ group, data = sleep)

	Welch Two Sample t-test

data:  extra by group
t = -1.8608, df = 17.776, p-value = 0.07939
alternative hypothesis: true difference in means between group 1 and group 2 is not equal to 0
95 percent confidence interval:
 -3.3654832  0.2054832
sample estimates:
mean in group 1 mean in group 2 
           0.75            2.33 

> 
> ## Formula interface to one-sample test
> t.test(extra ~ 1, data = sleep)

	One Sample t-test

data:  extra
t = 3.413, df = 19, p-value = 0.002918
alternative hypothesis: true mean is not equal to 0
95 percent confidence interval:
 0.5955845 2.4844155
sample estimates:
mean of x 
     1.54 

> 
> ## Formula interface to paired test
> ## The sleep data are actually paired, so could have been in wide format:
> sleep2 <- reshape(sleep, direction = "wide", 
+                   idvar = "ID", timevar = "group")
> t.test(Pair(extra.1, extra.2) ~ 1, data = sleep2)

	Paired t-test

data:  Pair(extra.1, extra.2)
t = -4.0621, df = 9, p-value = 0.002833
alternative hypothesis: true mean difference is not equal to 0
95 percent confidence interval:
 -2.4598858 -0.7001142
sample estimates:
mean difference 
          -1.58 

> 
> 
> 
> cleanEx()
> nameEx("termplot")
> ### * termplot
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: termplot
> ### Title: Plot Regression Terms
> ### Aliases: termplot
> ### Keywords: hplot regression
> 
> ### ** Examples
> 
> require(graphics)
> 
> had.splines <- "package:splines" %in% search()
> if(!had.splines) rs <- require(splines)
Loading required package: splines
> x <- 1:100
> z <- factor(rep(LETTERS[1:4], 25))
> y <- rnorm(100, sin(x/10)+as.numeric(z))
> model <- glm(y ~ ns(x, 6) + z)
> 
> par(mfrow = c(2,2)) ## 2 x 2 plots for same model :
> termplot(model, main = paste("termplot( ", deparse(model$call)," ...)"))
> termplot(model, rug = TRUE)
> termplot(model, partial.resid = TRUE, se = TRUE, main = TRUE)
> termplot(model, partial.resid = TRUE, smooth = panel.smooth, span.smth = 1/4)
> if(!had.splines && rs) detach("package:splines")
> 
> if(requireNamespace("MASS", quietly = TRUE)) {
+ hills.lm <- lm(log(time) ~ log(climb)+log(dist), data = MASS::hills)
+ termplot(hills.lm, partial.resid = TRUE, smooth = panel.smooth,
+         terms = "log(dist)", main = "Original")
+ termplot(hills.lm, transform.x = TRUE,
+          partial.resid = TRUE, smooth = panel.smooth,
+ 	 terms = "log(dist)", main = "Transformed")
+ 
+ }
> 
> 
> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
> cleanEx()
> nameEx("terms.object")
> ### * terms.object
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: terms.object
> ### Title: Description of Terms Objects
> ### Aliases: terms.object
> ### Keywords: models
> 
> ### ** Examples
> 
> ## use of specials (as used for gam() in packages mgcv and gam)
> (tf <- terms(y ~ x + x:z + s(x), specials = "s"))
y ~ x + x:z + s(x)
attr(,"variables")
list(y, x, z, s(x))
attr(,"factors")
     x s(x) x:z
y    0    0   0
x    1    0   2
z    0    0   1
s(x) 0    1   0
attr(,"term.labels")
[1] "x"    "s(x)" "x:z" 
attr(,"specials")
attr(,"specials")$s
[1] 4

attr(,"order")
[1] 1 1 2
attr(,"intercept")
[1] 1
attr(,"response")
[1] 1
attr(,".Environment")
<environment: R_GlobalEnv>
> ## Note that the "factors" attribute has variables as row names
> ## and term labels as column names, both as character vectors.
> attr(tf, "specials")    # index 's' variable(s)
$s
[1] 4

> rownames(attr(tf, "factors"))[attr(tf, "specials")$s]
[1] "s(x)"
> 
> ## we can keep the order by
> terms(y ~ x + x:z + s(x), specials = "s", keep.order = TRUE)
y ~ x + x:z + s(x)
attr(,"variables")
list(y, x, z, s(x))
attr(,"factors")
     x x:z s(x)
y    0   0    0
x    1   2    0
z    0   1    0
s(x) 0   0    1
attr(,"term.labels")
[1] "x"    "x:z"  "s(x)"
attr(,"specials")
attr(,"specials")$s
[1] 4

attr(,"order")
[1] 1 2 1
attr(,"intercept")
[1] 1
attr(,"response")
[1] 1
attr(,".Environment")
<environment: R_GlobalEnv>
> 
> 
> 
> cleanEx()
> nameEx("time")
> ### * time
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: time
> ### Title: Sampling Times of Time Series
> ### Aliases: time cycle frequency deltat time.default
> ### Keywords: ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> cycle(presidents)
     Qtr1 Qtr2 Qtr3 Qtr4
1945    1    2    3    4
1946    1    2    3    4
1947    1    2    3    4
1948    1    2    3    4
1949    1    2    3    4
1950    1    2    3    4
1951    1    2    3    4
1952    1    2    3    4
1953    1    2    3    4
1954    1    2    3    4
1955    1    2    3    4
1956    1    2    3    4
1957    1    2    3    4
1958    1    2    3    4
1959    1    2    3    4
1960    1    2    3    4
1961    1    2    3    4
1962    1    2    3    4
1963    1    2    3    4
1964    1    2    3    4
1965    1    2    3    4
1966    1    2    3    4
1967    1    2    3    4
1968    1    2    3    4
1969    1    2    3    4
1970    1    2    3    4
1971    1    2    3    4
1972    1    2    3    4
1973    1    2    3    4
1974    1    2    3    4
> # a simple series plot
> plot(as.vector(time(presidents)), as.vector(presidents), type = "l")
> 
> 
> 
> cleanEx()
> nameEx("toeplitz")
> ### * toeplitz
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: toeplitz
> ### Title: Form Symmetric Toeplitz Matrix
> ### Aliases: toeplitz
> ### Keywords: ts
> 
> ### ** Examples
> 
> x <- 1:5
> toeplitz (x)
     [,1] [,2] [,3] [,4] [,5]
[1,]    1    2    3    4    5
[2,]    2    1    2    3    4
[3,]    3    2    1    2    3
[4,]    4    3    2    1    2
[5,]    5    4    3    2    1
> 
> 
> 
> cleanEx()
> nameEx("ts")
> ### * ts
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ts
> ### Title: Time-Series Objects
> ### Aliases: ts as.ts as.ts.default is.ts Ops.ts cbind.ts is.mts [.ts t.ts
> ### Keywords: ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> ts(1:10, frequency = 4, start = c(1959, 2)) # 2nd Quarter of 1959
     Qtr1 Qtr2 Qtr3 Qtr4
1959         1    2    3
1960    4    5    6    7
1961    8    9   10     
> print( ts(1:10, frequency = 7, start = c(12, 2)), calendar = TRUE)
   p1 p2 p3 p4 p5 p6 p7
12     1  2  3  4  5  6
13  7  8  9 10         
> # print.ts(.)
> ## Using July 1954 as start date:
> gnp <- ts(cumsum(1 + round(rnorm(100), 2)),
+           start = c(1954, 7), frequency = 12)
> plot(gnp) # using 'plot.ts' for time-series plot
> 
> ## Multivariate
> z <- ts(matrix(rnorm(300), 100, 3), start = c(1961, 1), frequency = 12)
> class(z)
[1] "mts"    "ts"     "matrix"
> head(z) # as "matrix"
        Series 1   Series 2   Series 3
[1,] -0.62036668  0.4094018  0.8936737
[2,]  0.04211587  1.6888733 -1.0472981
[3,] -0.91092165  1.5865884  1.9713374
[4,]  0.15802877 -0.3309078 -0.3836321
[5,] -0.65458464 -2.2852355  1.6541453
[6,]  1.76728727  2.4976616  1.5122127
> plot(z)
> plot(z, plot.type = "single", lty = 1:3)
> 
> ## A phase plot:
> plot(nhtemp, lag(nhtemp, 1), cex = .8, col = "blue",
+      main = "Lag plot of New Haven temperatures")
> 
> 
> 
> cleanEx()
> nameEx("ts.plot")
> ### * ts.plot
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ts.plot
> ### Title: Plot Multiple Time Series
> ### Aliases: ts.plot
> ### Keywords: ts
> 
> ### ** Examples
> 
> require(graphics)
> 
> ts.plot(ldeaths, mdeaths, fdeaths,
+         gpars=list(xlab="year", ylab="deaths", lty=c(1:3)))
> 
> 
> 
> cleanEx()
> nameEx("ts.union")
> ### * ts.union
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ts.union
> ### Title: Bind Two or More Time Series
> ### Aliases: ts.union ts.intersect
> ### Keywords: ts
> 
> ### ** Examples
> 
> ts.union(mdeaths, fdeaths)
         mdeaths fdeaths
Jan 1974    2134     901
Feb 1974    1863     689
Mar 1974    1877     827
Apr 1974    1877     677
May 1974    1492     522
Jun 1974    1249     406
Jul 1974    1280     441
Aug 1974    1131     393
Sep 1974    1209     387
Oct 1974    1492     582
Nov 1974    1621     578
Dec 1974    1846     666
Jan 1975    2103     830
Feb 1975    2137     752
Mar 1975    2153     785
Apr 1975    1833     664
May 1975    1403     467
Jun 1975    1288     438
Jul 1975    1186     421
Aug 1975    1133     412
Sep 1975    1053     343
Oct 1975    1347     440
Nov 1975    1545     531
Dec 1975    2066     771
Jan 1976    2020     767
Feb 1976    2750    1141
Mar 1976    2283     896
Apr 1976    1479     532
May 1976    1189     447
Jun 1976    1160     420
Jul 1976    1113     376
Aug 1976     970     330
Sep 1976     999     357
Oct 1976    1208     445
Nov 1976    1467     546
Dec 1976    2059     764
Jan 1977    2240     862
Feb 1977    1634     660
Mar 1977    1722     663
Apr 1977    1801     643
May 1977    1246     502
Jun 1977    1162     392
Jul 1977    1087     411
Aug 1977    1013     348
Sep 1977     959     387
Oct 1977    1179     385
Nov 1977    1229     411
Dec 1977    1655     638
Jan 1978    2019     796
Feb 1978    2284     853
Mar 1978    1942     737
Apr 1978    1423     546
May 1978    1340     530
Jun 1978    1187     446
Jul 1978    1098     431
Aug 1978    1004     362
Sep 1978     970     387
Oct 1978    1140     430
Nov 1978    1110     425
Dec 1978    1812     679
Jan 1979    2263     821
Feb 1979    1820     785
Mar 1979    1846     727
Apr 1979    1531     612
May 1979    1215     478
Jun 1979    1075     429
Jul 1979    1056     405
Aug 1979     975     379
Sep 1979     940     393
Oct 1979    1081     411
Nov 1979    1294     487
Dec 1979    1341     574
> cbind(mdeaths, fdeaths) # same as the previous line
         mdeaths fdeaths
Jan 1974    2134     901
Feb 1974    1863     689
Mar 1974    1877     827
Apr 1974    1877     677
May 1974    1492     522
Jun 1974    1249     406
Jul 1974    1280     441
Aug 1974    1131     393
Sep 1974    1209     387
Oct 1974    1492     582
Nov 1974    1621     578
Dec 1974    1846     666
Jan 1975    2103     830
Feb 1975    2137     752
Mar 1975    2153     785
Apr 1975    1833     664
May 1975    1403     467
Jun 1975    1288     438
Jul 1975    1186     421
Aug 1975    1133     412
Sep 1975    1053     343
Oct 1975    1347     440
Nov 1975    1545     531
Dec 1975    2066     771
Jan 1976    2020     767
Feb 1976    2750    1141
Mar 1976    2283     896
Apr 1976    1479     532
May 1976    1189     447
Jun 1976    1160     420
Jul 1976    1113     376
Aug 1976     970     330
Sep 1976     999     357
Oct 1976    1208     445
Nov 1976    1467     546
Dec 1976    2059     764
Jan 1977    2240     862
Feb 1977    1634     660
Mar 1977    1722     663
Apr 1977    1801     643
May 1977    1246     502
Jun 1977    1162     392
Jul 1977    1087     411
Aug 1977    1013     348
Sep 1977     959     387
Oct 1977    1179     385
Nov 1977    1229     411
Dec 1977    1655     638
Jan 1978    2019     796
Feb 1978    2284     853
Mar 1978    1942     737
Apr 1978    1423     546
May 1978    1340     530
Jun 1978    1187     446
Jul 1978    1098     431
Aug 1978    1004     362
Sep 1978     970     387
Oct 1978    1140     430
Nov 1978    1110     425
Dec 1978    1812     679
Jan 1979    2263     821
Feb 1979    1820     785
Mar 1979    1846     727
Apr 1979    1531     612
May 1979    1215     478
Jun 1979    1075     429
Jul 1979    1056     405
Aug 1979     975     379
Sep 1979     940     393
Oct 1979    1081     411
Nov 1979    1294     487
Dec 1979    1341     574
> ts.intersect(window(mdeaths, 1976), window(fdeaths, 1974, 1978))
         window(mdeaths, 1976) window(fdeaths, 1974, 1978)
Jan 1976                  2020                         767
Feb 1976                  2750                        1141
Mar 1976                  2283                         896
Apr 1976                  1479                         532
May 1976                  1189                         447
Jun 1976                  1160                         420
Jul 1976                  1113                         376
Aug 1976                   970                         330
Sep 1976                   999                         357
Oct 1976                  1208                         445
Nov 1976                  1467                         546
Dec 1976                  2059                         764
Jan 1977                  2240                         862
Feb 1977                  1634                         660
Mar 1977                  1722                         663
Apr 1977                  1801                         643
May 1977                  1246                         502
Jun 1977                  1162                         392
Jul 1977                  1087                         411
Aug 1977                  1013                         348
Sep 1977                   959                         387
Oct 1977                  1179                         385
Nov 1977                  1229                         411
Dec 1977                  1655                         638
Jan 1978                  2019                         796
> 
> sales1 <- ts.union(BJsales, lead = BJsales.lead)
> ts.intersect(sales1, lead3 = lag(BJsales.lead, -3))
Time Series:
Start = 4 
End = 150 
Frequency = 1 
    sales1.BJsales sales1.lead lead3
  4          198.9        9.75 10.01
  5          199.0       10.33 10.07
  6          200.2       10.13 10.32
  7          198.6       10.36  9.75
  8          200.0       10.32 10.33
  9          200.3       10.13 10.13
 10          201.2       10.16 10.36
 11          201.6       10.58 10.32
 12          201.5       10.62 10.13
 13          201.5       10.86 10.16
 14          203.5       11.20 10.58
 15          204.9       10.74 10.62
 16          207.1       10.56 10.86
 17          210.5       10.48 11.20
 18          210.5       10.77 10.74
 19          209.8       11.33 10.56
 20          208.8       10.96 10.48
 21          209.5       11.16 10.77
 22          213.2       11.70 11.33
 23          213.7       11.39 10.96
 24          215.1       11.42 11.16
 25          218.7       11.94 11.70
 26          219.8       11.24 11.39
 27          220.5       11.59 11.42
 28          223.8       10.96 11.94
 29          222.8       11.40 11.24
 30          223.8       11.02 11.59
 31          221.7       11.01 10.96
 32          222.3       11.23 11.40
 33          220.8       11.33 11.02
 34          219.4       10.83 11.01
 35          220.1       10.84 11.23
 36          220.6       11.14 11.33
 37          218.9       10.38 10.83
 38          217.8       10.90 10.84
 39          217.7       11.05 11.14
 40          215.0       11.11 10.38
 41          215.3       11.01 10.90
 42          215.9       11.22 11.05
 43          216.7       11.21 11.11
 44          216.7       11.91 11.01
 45          217.7       11.69 11.22
 46          218.7       10.93 11.21
 47          222.9       10.99 11.91
 48          224.9       11.01 11.69
 49          222.2       10.84 10.93
 50          220.7       10.76 10.99
 51          220.0       10.77 11.01
 52          218.7       10.88 10.84
 53          217.0       10.49 10.76
 54          215.9       10.50 10.77
 55          215.8       11.00 10.88
 56          214.1       10.98 10.49
 57          212.3       10.61 10.50
 58          213.9       10.48 11.00
 59          214.6       10.53 10.98
 60          213.6       11.07 10.61
 61          212.1       10.61 10.48
 62          211.4       10.86 10.53
 63          213.1       10.34 11.07
 64          212.9       10.78 10.61
 65          213.3       10.80 10.86
 66          211.5       10.33 10.34
 67          212.3       10.44 10.78
 68          213.0       10.50 10.80
 69          211.0       10.75 10.33
 70          210.7       10.40 10.44
 71          210.1       10.40 10.50
 72          211.4       10.34 10.75
 73          210.0       10.55 10.40
 74          209.7       10.46 10.40
 75          208.8       10.82 10.34
 76          208.8       10.91 10.55
 77          208.8       10.87 10.46
 78          210.6       10.67 10.82
 79          211.9       11.11 10.91
 80          212.8       10.88 10.87
 81          212.5       11.28 10.67
 82          214.8       11.27 11.11
 83          215.3       11.44 10.88
 84          217.5       11.52 11.28
 85          218.8       12.10 11.27
 86          220.7       11.83 11.44
 87          222.2       12.62 11.52
 88          226.7       12.41 12.10
 89          228.4       12.43 11.83
 90          233.2       12.73 12.62
 91          235.7       13.01 12.41
 92          237.1       12.74 12.43
 93          240.6       12.73 12.73
 94          243.8       12.76 13.01
 95          245.3       12.92 12.74
 96          246.0       12.64 12.73
 97          246.3       12.79 12.76
 98          247.7       13.05 12.92
 99          247.6       12.69 12.64
100          247.8       13.01 12.79
101          249.4       12.90 13.05
102          249.0       13.12 12.69
103          249.9       12.47 13.01
104          250.5       12.47 12.90
105          251.5       12.94 13.12
106          249.0       13.10 12.47
107          247.6       12.91 12.47
108          248.8       13.39 12.94
109          250.4       13.13 13.10
110          250.7       13.34 12.91
111          253.0       13.34 13.39
112          253.7       13.14 13.13
113          255.0       13.49 13.34
114          256.2       13.87 13.34
115          256.0       13.39 13.14
116          257.4       13.59 13.49
117          260.4       13.27 13.87
118          260.0       13.70 13.39
119          261.3       13.20 13.59
120          260.4       13.32 13.27
121          261.6       13.15 13.70
122          260.8       13.30 13.20
123          259.8       12.94 13.32
124          259.0       13.29 13.15
125          258.9       13.26 13.30
126          257.4       13.08 12.94
127          257.7       13.24 13.29
128          257.9       13.31 13.26
129          257.4       13.52 13.08
130          257.3       13.02 13.24
131          257.6       13.25 13.31
132          258.9       13.12 13.52
133          257.8       13.26 13.02
134          257.7       13.11 13.25
135          257.2       13.30 13.12
136          257.5       13.06 13.26
137          256.8       13.32 13.11
138          257.5       13.10 13.30
139          257.0       13.27 13.06
140          257.6       13.64 13.32
141          257.3       13.58 13.10
142          257.5       13.87 13.27
143          259.6       13.53 13.64
144          261.1       13.41 13.58
145          262.9       13.25 13.87
146          263.3       13.50 13.53
147          262.8       13.58 13.41
148          261.8       13.51 13.25
149          262.2       13.77 13.50
150          262.7       13.40 13.58
> 
> 
> 
> cleanEx()
> nameEx("tsdiag")
> ### * tsdiag
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: tsdiag
> ### Title: Diagnostic Plots for Time-Series Fits
> ### Aliases: tsdiag tsdiag.arima0 tsdiag.Arima tsdiag.StructTS
> ### Keywords: ts
> 
> ### ** Examples
> 
> 
> 
> cleanEx()
> nameEx("uniroot")
> ### * uniroot
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: uniroot
> ### Title: One Dimensional Root (Zero) Finding
> ### Aliases: uniroot
> ### Keywords: optimize
> 
> ### ** Examples
> 
> ##--- uniroot() with new interval extension + checking features: --------------
> 
> f1 <- function(x) (121 - x^2)/(x^2+1)
> f2 <- function(x) exp(-x)*(x - 12)
> 
> try(uniroot(f1, c(0,10)))
Error in uniroot(f1, c(0, 10)) : 
  f() values at end points not of opposite sign
> try(uniroot(f2, c(0, 2)))
Error in uniroot(f2, c(0, 2)) : 
  f() values at end points not of opposite sign
> ##--> error: f() .. end points not of opposite sign
> 
> ## where as  'extendInt="yes"'  simply first enlarges the search interval:
> u1 <- uniroot(f1, c(0,10),extendInt="yes", trace=1)
search in [0,10] ... extended to [-1.5e-05, 11.5] in 4 steps
> u2 <- uniroot(f2, c(0,2), extendInt="yes", trace=2)
search in [0,2]
 .. modified lower,upper: (         -1e-06,           2.02)
 .. modified lower,upper: (         -3e-06,           2.06)
 .. modified lower,upper: (         -7e-06,           2.14)
 .. modified lower,upper: (       -1.5e-05,            2.3)
 .. modified lower,upper: (       -3.1e-05,           2.62)
 .. modified lower,upper: (       -6.3e-05,           3.26)
 .. modified lower,upper: (      -0.000127,           4.54)
 .. modified lower,upper: (      -0.000255,            7.1)
 .. modified lower,upper: (      -0.000511,          12.22)
> stopifnot(all.equal(u1$root, 11, tolerance = 1e-5),
+           all.equal(u2$root, 12, tolerance = 6e-6))
> 
> ## The *danger* of interval extension:
> ## No way to find a zero of a positive function, but
> ## numerically, f(-|M|) becomes zero :
> u3 <- uniroot(exp, c(0,2), extendInt="yes", trace=TRUE)
search in [0,2] ... extended to [-1073.74, 2.14748e+07] in 30 steps
> 
> ## Nonsense example (must give an error):
> tools::assertCondition( uniroot(function(x) 1, 0:1, extendInt="yes"),
+                        "error", verbose=TRUE)
assertCondition: caught “error”
> 
> ## Convergence checking :
> sinc <- function(x) ifelse(x == 0, 1, sin(x)/x)
> curve(sinc, -6,18); abline(h=0,v=0, lty=3, col=adjustcolor("gray", 0.8))
> ## Don't show: 
> tools::assertWarning(
+ ## End(Don't show)
+ uniroot(sinc, c(0,5), extendInt="yes", maxiter=4) #-> "just" a warning
+ ## Don't show: 
+  , verbose=TRUE)
Asserted warning: _NOT_ converged in 4 iterations
> ## End(Don't show)
> 
> ## now with  check.conv=TRUE, must signal a convergence error :
> ## Don't show: 
> tools::assertError(
+ ## End(Don't show)
+ uniroot(sinc, c(0,5), extendInt="yes", maxiter=4, check.conv=TRUE)
+ ## Don't show: 
+  , verbose=TRUE)
Asserted error: _NOT_ converged in 4 iterations
> ## End(Don't show)
> 
> ### Weibull cumulative hazard (example origin, Ravi Varadhan):
> cumhaz <- function(t, a, b) b * (t/b)^a
> froot <- function(x, u, a, b) cumhaz(x, a, b) - u
> 
> n <- 1000
> u <- -log(runif(n))
> a <- 1/2
> b <- 1
> ## Find failure times
> ru <- sapply(u, function(x)
+    uniroot(froot, u=x, a=a, b=b, interval= c(1.e-14, 1e04),
+            extendInt="yes")$root)
> ru2 <- sapply(u, function(x)
+    uniroot(froot, u=x, a=a, b=b, interval= c(0.01,  10),
+            extendInt="yes")$root)
> stopifnot(all.equal(ru, ru2, tolerance = 6e-6))
> 
> r1 <- uniroot(froot, u= 0.99, a=a, b=b, interval= c(0.01, 10),
+              extendInt="up")
> stopifnot(all.equal(0.99, cumhaz(r1$root, a=a, b=b)))
> 
> ## An error if 'extendInt' assumes "wrong zero-crossing direction":
> ## Don't show: 
> tools::assertError(
+ ## End(Don't show)
+ uniroot(froot, u= 0.99, a=a, b=b, interval= c(0.1, 10), extendInt="down")
+ ## Don't show: 
+  , verbose=TRUE)
Asserted error: no sign change found in 1000 iterations
> ## End(Don't show)
> 
> 
> 
> cleanEx()
> nameEx("update")
> ### * update
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: update
> ### Title: Update and Re-fit a Model Call
> ### Aliases: update update.default getCall getCall.default
> ### Keywords: models
> 
> ### ** Examples
> 
> oldcon <- options(contrasts = c("contr.treatment", "contr.poly"))
> ## Annette Dobson (1990) "An Introduction to Generalized Linear Models".
> ## Page 9: Plant Weight Data.
> 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, 20, labels = c("Ctl", "Trt"))
> weight <- c(ctl, trt)
> lm.D9 <- lm(weight ~ group)
> lm.D9

Call:
lm(formula = weight ~ group)

Coefficients:
(Intercept)     groupTrt  
      5.032       -0.371  

> summary(lm.D90 <- update(lm.D9, . ~ . - 1))

Call:
lm(formula = weight ~ group - 1)

Residuals:
    Min      1Q  Median      3Q     Max 
-1.0710 -0.4938  0.0685  0.2462  1.3690 

Coefficients:
         Estimate Std. Error t value Pr(>|t|)    
groupCtl   5.0320     0.2202   22.85 9.55e-15 ***
groupTrt   4.6610     0.2202   21.16 3.62e-14 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 0.6964 on 18 degrees of freedom
Multiple R-squared:  0.9818,	Adjusted R-squared:  0.9798 
F-statistic: 485.1 on 2 and 18 DF,  p-value: < 2.2e-16

> options(contrasts = c("contr.helmert", "contr.poly"))
> update(lm.D9)

Call:
lm(formula = weight ~ group)

Coefficients:
(Intercept)       group1  
     4.8465      -0.1855  

> getCall(lm.D90)  # "through the origin"
lm(formula = weight ~ group - 1)
> 
> options(oldcon)
> 
> 
> 
> base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
> cleanEx()
> nameEx("update.formula")
> ### * update.formula
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: update.formula
> ### Title: Model Updating
> ### Aliases: update.formula
> ### Keywords: models
> 
> ### ** Examples
> 
> update(y ~ x,    ~ . + x2) #> y ~ x + x2
y ~ x + x2
> update(y ~ x, log(.) ~ . ) #> log(y) ~ x
log(y) ~ x
> update(. ~ u+v, res  ~ . ) #> res ~ u + v
res ~ u + v
> 
> 
> 
> cleanEx()
> nameEx("var.test")
> ### * var.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: var.test
> ### Title: F Test to Compare Two Variances
> ### Aliases: var.test var.test.default var.test.formula
> ### Keywords: htest
> 
> ### ** Examples
> 
> x <- rnorm(50, mean = 0, sd = 2)
> y <- rnorm(30, mean = 1, sd = 1)
> var.test(x, y)                  # Do x and y have the same variance?

	F test to compare two variances

data:  x and y
F = 2.6522, num df = 49, denom df = 29, p-value = 0.006232
alternative hypothesis: true ratio of variances is not equal to 1
95 percent confidence interval:
 1.332510 4.989832
sample estimates:
ratio of variances 
          2.652168 

> var.test(lm(x ~ 1), lm(y ~ 1))  # The same.

	F test to compare two variances

data:  lm(x ~ 1) and lm(y ~ 1)
F = 2.6522, num df = 49, denom df = 29, p-value = 0.006232
alternative hypothesis: true ratio of variances is not equal to 1
95 percent confidence interval:
 1.332510 4.989832
sample estimates:
ratio of variances 
          2.652168 

> 
> 
> 
> cleanEx()
> nameEx("varimax")
> ### * varimax
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: varimax
> ### Title: Rotation Methods for Factor Analysis
> ### Aliases: promax varimax
> ### Keywords: multivariate
> 
> ### ** Examples
> 
> ## varimax with normalize = TRUE is the default
> fa <- factanal( ~., 2, data = swiss)
> varimax(loadings(fa), normalize = FALSE)
$loadings

Loadings:
                 Factor1 Factor2
Fertility        -0.650   0.398 
Agriculture      -0.628   0.337 
Examination       0.681  -0.515 
Education         0.997         
Catholic         -0.117   0.962 
Infant.Mortality          0.176 

               Factor1 Factor2
SS loadings      2.297   1.496
Proportion Var   0.383   0.249
Cumulative Var   0.383   0.632

$rotmat
            [,1]         [,2]
[1,] 0.999973881 -0.007227595
[2,] 0.007227595  0.999973881

> promax(loadings(fa))
$loadings

Loadings:
                 Factor1 Factor2
Fertility        -0.595   0.227 
Agriculture      -0.599   0.160 
Examination       0.577  -0.360 
Education         1.192   0.363 
Catholic          0.326   1.147 
Infant.Mortality          0.180 

               Factor1 Factor2
SS loadings      2.574   1.686
Proportion Var   0.429   0.281
Cumulative Var   0.429   0.710

$rotmat
          [,1]      [,2]
[1,] 1.2114045 0.4029296
[2,] 0.4956199 1.2453063

> 
> 
> 
> cleanEx()
> nameEx("weighted.mean")
> ### * weighted.mean
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: weighted.mean
> ### Title: Weighted Arithmetic Mean
> ### Aliases: weighted.mean weighted.mean.default
> ### Keywords: univar
> 
> ### ** Examples
> 
> ## GPA from Siegel 1994
> wt <- c(5,  5,  4,  1)/15
> x <- c(3.7,3.3,3.5,2.8)
> xm <- weighted.mean(x, wt)
> 
> 
> 
> cleanEx()
> nameEx("weighted.residuals")
> ### * weighted.residuals
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: weighted.residuals
> ### Title: Compute Weighted Residuals
> ### Aliases: weighted.residuals
> ### Keywords: regression
> 
> ### ** Examples
> 
> ## following on from example(lm)
> ## Don't show: 
> utils::example("lm", echo = FALSE)
> ## End(Don't show)
> all.equal(weighted.residuals(lm.D9),
+           residuals(lm.D9))
[1] TRUE
> x <- 1:10
> w <- 0:9
> y <- rnorm(x)
> weighted.residuals(lmxy <- lm(y ~ x, weights = w))
          2           3           4           5           6           7 
-0.15744267 -1.63534445  2.24282864  0.09895229 -2.41528559  0.60771924 
          8           9          10 
 1.37406419  1.06675699 -1.45098819 
> weighted.residuals(lmxy, drop0 = FALSE)
          1           2           3           4           5           6 
 0.00000000 -0.15744267 -1.63534445  2.24282864  0.09895229 -2.41528559 
          7           8           9          10 
 0.60771924  1.37406419  1.06675699 -1.45098819 
> 
> 
> 
> cleanEx()
> nameEx("wilcox.test")
> ### * wilcox.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: wilcox.test
> ### Title: Wilcoxon Rank Sum and Signed Rank Tests
> ### Aliases: wilcox.test wilcox.test.default wilcox.test.formula
> ### Keywords: htest
> 
> ### ** Examples
> 
> require(graphics)
> ## One-sample test.
> ## Hollander & Wolfe (1973), 29f.
> ## Hamilton depression scale factor measurements in 9 patients with
> ##  mixed anxiety and depression, taken at the first (x) and second
> ##  (y) visit after initiation of a therapy (administration of a
> ##  tranquilizer).
> x <- c(1.83,  0.50,  1.62,  2.48, 1.68, 1.88, 1.55, 3.06, 1.30)
> y <- c(0.878, 0.647, 0.598, 2.05, 1.06, 1.29, 1.06, 3.14, 1.29)
> wilcox.test(x, y, paired = TRUE, alternative = "greater")

	Wilcoxon signed rank exact test

data:  x and y
V = 40, p-value = 0.01953
alternative hypothesis: true location shift is greater than 0

> wilcox.test(y - x, alternative = "less")    # The same.

	Wilcoxon signed rank exact test

data:  y - x
V = 5, p-value = 0.01953
alternative hypothesis: true location is less than 0

> wilcox.test(y - x, alternative = "less",
+             exact = FALSE, correct = FALSE) # H&W large sample

	Wilcoxon signed rank test

data:  y - x
V = 5, p-value = 0.01908
alternative hypothesis: true location is less than 0

>                                             # approximation
> 
> ## Formula interface to one-sample and paired tests
> 
> depression <- data.frame(first = x, second = y, change = y - x)
> wilcox.test(change ~ 1, data = depression)

	Wilcoxon signed rank exact test

data:  change
V = 5, p-value = 0.03906
alternative hypothesis: true location is not equal to 0

> wilcox.test(Pair(first, second) ~ 1, data = depression)

	Wilcoxon signed rank exact test

data:  Pair(first, second)
V = 40, p-value = 0.03906
alternative hypothesis: true location shift is not equal to 0

> 
> ## Two-sample test.
> ## Hollander & Wolfe (1973), 69f.
> ## Permeability constants of the human chorioamnion (a placental
> ##  membrane) at term (x) and between 12 to 26 weeks gestational
> ##  age (y).  The alternative of interest is greater permeability
> ##  of the human chorioamnion for the term pregnancy.
> x <- c(0.80, 0.83, 1.89, 1.04, 1.45, 1.38, 1.91, 1.64, 0.73, 1.46)
> y <- c(1.15, 0.88, 0.90, 0.74, 1.21)
> wilcox.test(x, y, alternative = "g")        # greater

	Wilcoxon rank sum exact test

data:  x and y
W = 35, p-value = 0.1272
alternative hypothesis: true location shift is greater than 0

> wilcox.test(x, y, alternative = "greater",
+             exact = FALSE, correct = FALSE) # H&W large sample

	Wilcoxon rank sum test

data:  x and y
W = 35, p-value = 0.1103
alternative hypothesis: true location shift is greater than 0

>                                             # approximation
> 
> wilcox.test(rnorm(10), rnorm(10, 2), conf.int = TRUE)

	Wilcoxon rank sum exact test

data:  rnorm(10) and rnorm(10, 2)
W = 7, p-value = 0.0004871
alternative hypothesis: true location shift is not equal to 0
95 percent confidence interval:
 -3.024352 -1.348555
sample estimates:
difference in location 
             -2.262424 

> 
> ## Formula interface.
> boxplot(Ozone ~ Month, data = airquality)
> wilcox.test(Ozone ~ Month, data = airquality,
+             subset = Month %in% c(5, 8))
Warning in wilcox.test.default(x = DATA[[1L]], y = DATA[[2L]], ...) :
  cannot compute exact p-value with ties

	Wilcoxon rank sum test with continuity correction

data:  Ozone by Month
W = 127.5, p-value = 0.0001208
alternative hypothesis: true location shift is not equal to 0

> 
> ## accuracy in ties determination via 'digits.rank':
> wilcox.test( 4:2,      3:1,     paired=TRUE) # Warning:  cannot compute exact p-value with ties
Warning in wilcox.test.default(4:2, 3:1, paired = TRUE) :
  cannot compute exact p-value with ties

	Wilcoxon signed rank test with continuity correction

data:  4:2 and 3:1
V = 6, p-value = 0.1489
alternative hypothesis: true location shift is not equal to 0

> wilcox.test((4:2)/10, (3:1)/10, paired=TRUE) # no ties => *no* warning

	Wilcoxon signed rank exact test

data:  (4:2)/10 and (3:1)/10
V = 6, p-value = 0.25
alternative hypothesis: true location shift is not equal to 0

> wilcox.test((4:2)/10, (3:1)/10, paired=TRUE, digits.rank = 9) # same ties as (4:2, 3:1)
Warning in wilcox.test.default((4:2)/10, (3:1)/10, paired = TRUE, digits.rank = 9) :
  cannot compute exact p-value with ties

	Wilcoxon signed rank test with continuity correction

data:  (4:2)/10 and (3:1)/10
V = 6, p-value = 0.1489
alternative hypothesis: true location shift is not equal to 0

> 
> 
> 
> cleanEx()
> nameEx("window")
> ### * window
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: window
> ### Title: Time (Series) Windows
> ### Aliases: window window.default window.ts window<- window<-.ts
> ### Keywords: ts
> 
> ### ** Examples
> 
> window(presidents, 1960, c(1969,4)) # values in the 1960's
     Qtr1 Qtr2 Qtr3 Qtr4
1960   71   62   61   57
1961   72   83   71   78
1962   79   71   62   74
1963   76   64   62   57
1964   80   73   69   69
1965   71   64   69   62
1966   63   46   56   44
1967   44   52   38   46
1968   36   49   35   44
1969   59   65   65   56
> window(presidents, deltat = 1)  # All Qtr1s
Time Series:
Start = 1945 
End = 1974 
Frequency = 1 
 [1] NA 63 35 36 69 45 36 25 59 71 71 76 79 60 57 71 72 79 76 80 71 63 44 36 59
[26] 66 51 49 68 28
> window(presidents, start = c(1945,3), deltat = 1)  # All Qtr3s
Time Series:
Start = 1945.5 
End = 1974.5 
Frequency = 1 
 [1] 82 43 54 NA 57 46 32 NA 75 71 79 67 63 48 61 61 71 62 62 69 69 56 38 35 65
[26] 61 54 NA 40 24
> window(presidents, 1944, c(1979,2), extend = TRUE)
     Qtr1 Qtr2 Qtr3 Qtr4
1944   NA   NA   NA   NA
1945   NA   87   82   75
1946   63   50   43   32
1947   35   60   54   55
1948   36   39   NA   NA
1949   69   57   57   51
1950   45   37   46   39
1951   36   24   32   23
1952   25   32   NA   32
1953   59   74   75   60
1954   71   61   71   57
1955   71   68   79   73
1956   76   71   67   75
1957   79   62   63   57
1958   60   49   48   52
1959   57   62   61   66
1960   71   62   61   57
1961   72   83   71   78
1962   79   71   62   74
1963   76   64   62   57
1964   80   73   69   69
1965   71   64   69   62
1966   63   46   56   44
1967   44   52   38   46
1968   36   49   35   44
1969   59   65   65   56
1970   66   53   61   52
1971   51   48   54   49
1972   49   61   NA   NA
1973   68   44   40   27
1974   28   25   24   24
1975   NA   NA   NA   NA
1976   NA   NA   NA   NA
1977   NA   NA   NA   NA
1978   NA   NA   NA   NA
1979   NA   NA          
> 
> pres <- window(presidents, 1945, c(1949,4)) # values in the 1940's
> window(pres, 1945.25, 1945.50) <- c(60, 70)
> window(pres, 1944, 1944.75) <- 0 # will generate a warning
Warning: extending time series when replacing values
> window(pres, c(1945,4), c(1949,4), frequency = 1) <- 85:89
> pres
     Qtr1 Qtr2 Qtr3 Qtr4
1944    0    0    0    0
1945   NA   60   70   85
1946   63   50   43   86
1947   35   60   54   87
1948   36   39   NA   88
1949   69   57   57   89
> 
> 
> 
> cleanEx()
> nameEx("xtabs")
> ### * xtabs
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: xtabs
> ### Title: Cross Tabulation
> ### Aliases: xtabs print.xtabs
> ### Keywords: category
> 
> ### ** Examples
> 
> ## 'esoph' has the frequencies of cases and controls for all levels of
> ## the variables 'agegp', 'alcgp', and 'tobgp'.
> xtabs(cbind(ncases, ncontrols) ~ ., data = esoph)
, , tobgp = 0-9g/day,  = ncases

       alcgp
agegp   0-39g/day 40-79 80-119 120+
  25-34         0     0      0    0
  35-44         0     0      0    2
  45-54         1     6      3    4
  55-64         2     9      9    5
  65-74         5    17      6    3
  75+           1     2      1    2

, , tobgp = 10-19,  = ncases

       alcgp
agegp   0-39g/day 40-79 80-119 120+
  25-34         0     0      0    1
  35-44         1     3      0    0
  45-54         0     4      6    3
  55-64         3     6      8    6
  65-74         4     3      4    1
  75+           2     1      1    1

, , tobgp = 20-29,  = ncases

       alcgp
agegp   0-39g/day 40-79 80-119 120+
  25-34         0     0      0    0
  35-44         0     1      0    2
  45-54         0     5      1    2
  55-64         3     4      3    2
  65-74         2     5      2    1
  75+           0     0      0    0

, , tobgp = 30+,  = ncases

       alcgp
agegp   0-39g/day 40-79 80-119 120+
  25-34         0     0      0    0
  35-44         0     0      0    0
  45-54         0     5      2    4
  55-64         4     3      4    5
  65-74         0     0      1    1
  75+           1     1      0    0

, , tobgp = 0-9g/day,  = ncontrols

       alcgp
agegp   0-39g/day 40-79 80-119 120+
  25-34        40    27      2    1
  35-44        60    35     11    1
  45-54        45    32     13    0
  55-64        47    31      9    5
  65-74        43    17      7    1
  75+          17     3      0    0

, , tobgp = 10-19,  = ncontrols

       alcgp
agegp   0-39g/day 40-79 80-119 120+
  25-34        10     7      1    0
  35-44        13    20      6    3
  45-54        18    17      8    1
  55-64        19    15      7    1
  65-74        10     7      8    1
  75+           4     2      0    0

, , tobgp = 20-29,  = ncontrols

       alcgp
agegp   0-39g/day 40-79 80-119 120+
  25-34         6     4      0    1
  35-44         7    13      2    2
  45-54        10    10      4    1
  55-64         9    13      3    1
  65-74         5     4      1    0
  75+           0     3      0    0

, , tobgp = 30+,  = ncontrols

       alcgp
agegp   0-39g/day 40-79 80-119 120+
  25-34         5     7      2    2
  35-44         8     8      1    0
  45-54         4     2      2    0
  55-64         2     3      0    1
  65-74         2     0      0    0
  75+           2     0      0    0

> ## Output is not really helpful ... flat tables are better:
> ftable(xtabs(cbind(ncases, ncontrols) ~ ., data = esoph))
                          ncases ncontrols
agegp alcgp     tobgp                     
25-34 0-39g/day 0-9g/day       0        40
                10-19          0        10
                20-29          0         6
                30+            0         5
      40-79     0-9g/day       0        27
                10-19          0         7
                20-29          0         4
                30+            0         7
      80-119    0-9g/day       0         2
                10-19          0         1
                20-29          0         0
                30+            0         2
      120+      0-9g/day       0         1
                10-19          1         0
                20-29          0         1
                30+            0         2
35-44 0-39g/day 0-9g/day       0        60
                10-19          1        13
                20-29          0         7
                30+            0         8
      40-79     0-9g/day       0        35
                10-19          3        20
                20-29          1        13
                30+            0         8
      80-119    0-9g/day       0        11
                10-19          0         6
                20-29          0         2
                30+            0         1
      120+      0-9g/day       2         1
                10-19          0         3
                20-29          2         2
                30+            0         0
45-54 0-39g/day 0-9g/day       1        45
                10-19          0        18
                20-29          0        10
                30+            0         4
      40-79     0-9g/day       6        32
                10-19          4        17
                20-29          5        10
                30+            5         2
      80-119    0-9g/day       3        13
                10-19          6         8
                20-29          1         4
                30+            2         2
      120+      0-9g/day       4         0
                10-19          3         1
                20-29          2         1
                30+            4         0
55-64 0-39g/day 0-9g/day       2        47
                10-19          3        19
                20-29          3         9
                30+            4         2
      40-79     0-9g/day       9        31
                10-19          6        15
                20-29          4        13
                30+            3         3
      80-119    0-9g/day       9         9
                10-19          8         7
                20-29          3         3
                30+            4         0
      120+      0-9g/day       5         5
                10-19          6         1
                20-29          2         1
                30+            5         1
65-74 0-39g/day 0-9g/day       5        43
                10-19          4        10
                20-29          2         5
                30+            0         2
      40-79     0-9g/day      17        17
                10-19          3         7
                20-29          5         4
                30+            0         0
      80-119    0-9g/day       6         7
                10-19          4         8
                20-29          2         1
                30+            1         0
      120+      0-9g/day       3         1
                10-19          1         1
                20-29          1         0
                30+            1         0
75+   0-39g/day 0-9g/day       1        17
                10-19          2         4
                20-29          0         0
                30+            1         2
      40-79     0-9g/day       2         3
                10-19          1         2
                20-29          0         3
                30+            1         0
      80-119    0-9g/day       1         0
                10-19          1         0
                20-29          0         0
                30+            0         0
      120+      0-9g/day       2         0
                10-19          1         0
                20-29          0         0
                30+            0         0
> ## In particular if we have fewer factors ...
> ftable(xtabs(cbind(ncases, ncontrols) ~ agegp, data = esoph))
       ncases ncontrols
agegp                  
25-34       1       115
35-44       9       190
45-54      46       167
55-64      76       166
65-74      55       106
75+        13        31
> 
> ## This is already a contingency table in array form.
> DF <- as.data.frame(UCBAdmissions)
> ## Now 'DF' is a data frame with a grid of the factors and the counts
> ## in variable 'Freq'.
> DF
      Admit Gender Dept Freq
1  Admitted   Male    A  512
2  Rejected   Male    A  313
3  Admitted Female    A   89
4  Rejected Female    A   19
5  Admitted   Male    B  353
6  Rejected   Male    B  207
7  Admitted Female    B   17
8  Rejected Female    B    8
9  Admitted   Male    C  120
10 Rejected   Male    C  205
11 Admitted Female    C  202
12 Rejected Female    C  391
13 Admitted   Male    D  138
14 Rejected   Male    D  279
15 Admitted Female    D  131
16 Rejected Female    D  244
17 Admitted   Male    E   53
18 Rejected   Male    E  138
19 Admitted Female    E   94
20 Rejected Female    E  299
21 Admitted   Male    F   22
22 Rejected   Male    F  351
23 Admitted Female    F   24
24 Rejected Female    F  317
> ## Nice for taking margins ...
> xtabs(Freq ~ Gender + Admit, DF)
        Admit
Gender   Admitted Rejected
  Male       1198     1493
  Female      557     1278
> ## And for testing independence ...
> summary(xtabs(Freq ~ ., DF))
Call: xtabs(formula = Freq ~ ., data = DF)
Number of cases in table: 4526 
Number of factors: 3 
Test for independence of all factors:
	Chisq = 2000.3, df = 16, p-value = 0
> 
> ## with NA's
> DN <- DF; DN[cbind(6:9, c(1:2,4,1))] <- NA
> DN # 'Freq' is missing only for (Rejected, Female, B)
      Admit Gender Dept Freq
1  Admitted   Male    A  512
2  Rejected   Male    A  313
3  Admitted Female    A   89
4  Rejected Female    A   19
5  Admitted   Male    B  353
6      <NA>   Male    B  207
7  Admitted   <NA>    B   17
8  Rejected Female    B   NA
9      <NA>   Male    C  120
10 Rejected   Male    C  205
11 Admitted Female    C  202
12 Rejected Female    C  391
13 Admitted   Male    D  138
14 Rejected   Male    D  279
15 Admitted Female    D  131
16 Rejected Female    D  244
17 Admitted   Male    E   53
18 Rejected   Male    E  138
19 Admitted Female    E   94
20 Rejected Female    E  299
21 Admitted   Male    F   22
22 Rejected   Male    F  351
23 Admitted Female    F   24
24 Rejected Female    F  317
> tools::assertError(# 'na.fail' should fail :
+      xtabs(Freq ~ Gender + Admit, DN, na.action=na.fail), verbose=TRUE)
Asserted error: missing values in object
> op <- options(na.action = "na.omit") # the "factory" default
> (xtabs(Freq ~ Gender + Admit, DN) -> xtD)
        Admit
Gender   Admitted Rejected
  Male       1078     1286
  Female      540     1270
> noC <- function(O) `attr<-`(O, "call", NULL)
> ident_noC <- function(x,y) identical(noC(x), noC(y))
> stopifnot(exprs = {
+   ident_noC(xtD, xtabs(Freq ~ Gender + Admit, DN, na.action = na.omit))
+   ident_noC(xtD, xtabs(Freq ~ Gender + Admit, DN, na.action = NULL))
+ })
> 
> xtabs(Freq ~ Gender + Admit, DN, na.action = na.pass)
        Admit
Gender   Admitted Rejected
  Male       1078     1286
  Female      540         
> ## The Female:Rejected combination has NA 'Freq' (and NA prints 'invisibly' as "")
> (xtNA <- xtabs(Freq ~ Gender + Admit, DN, addNA = TRUE)) # ==> count NAs
        Admit
Gender   Admitted Rejected <NA>
  Male       1078     1286  327
  Female      540             0
  <NA>         17        0    0
> ## show NA's better via  na.print = ".." :
> print(xtNA, na.print= "NA")
        Admit
Gender   Admitted Rejected <NA>
  Male       1078     1286  327
  Female      540       NA    0
  <NA>         17        0    0
> 
> 
> ## Create a nice display for the warp break data.
> warpbreaks$replicate <- rep_len(1:9, 54)
> ftable(xtabs(breaks ~ wool + tension + replicate, data = warpbreaks))
             replicate  1  2  3  4  5  6  7  8  9
wool tension                                     
A    L                 26 30 54 25 70 52 51 26 67
     M                 18 21 29 17 12 18 35 30 36
     H                 36 21 24 18 10 43 28 15 26
B    L                 27 14 29 19 29 31 41 20 44
     M                 42 26 19 16 39 28 21 39 29
     H                 20 21 24 17 13 15 15 16 28
> 
> ### ---- Sparse Examples ----
> 
> 
> 
> 
> cleanEx()
> nameEx("zC")
> ### * zC
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: C
> ### Title: Sets Contrasts for a Factor
> ### Aliases: C
> ### Keywords: models
> 
> ### ** Examples
> 
> ## reset contrasts to defaults
> options(contrasts = c("contr.treatment", "contr.poly"))
> tens <- with(warpbreaks, C(tension, poly, 1))
> ## tension SHOULD be an ordered factor, but as it is not we can use
> aov(breaks ~ wool + tens + tension, data = warpbreaks)
Call:
   aov(formula = breaks ~ wool + tens + tension, data = warpbreaks)

Terms:
                    wool     tens  tension Residuals
Sum of Squares   450.667 1950.694   83.565  6747.889
Deg. of Freedom        1        1        1        50

Residual standard error: 11.61713
1 out of 5 effects not estimable
Estimated effects may be unbalanced
> 
> ## show the use of ...  The default contrast is contr.treatment here
> summary(lm(breaks ~ wool + C(tension, base = 2), data = warpbreaks))

Call:
lm(formula = breaks ~ wool + C(tension, base = 2), data = warpbreaks)

Residuals:
    Min      1Q  Median      3Q     Max 
-19.500  -8.083  -2.139   6.472  30.722 

Coefficients:
                      Estimate Std. Error t value Pr(>|t|)    
(Intercept)             29.278      3.162   9.260    2e-12 ***
woolB                   -5.778      3.162  -1.827   0.0736 .  
C(tension, base = 2)1   10.000      3.872   2.582   0.0128 *  
C(tension, base = 2)3   -4.722      3.872  -1.219   0.2284    
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 11.62 on 50 degrees of freedom
Multiple R-squared:  0.2691,	Adjusted R-squared:  0.2253 
F-statistic: 6.138 on 3 and 50 DF,  p-value: 0.00123

> 
> 
> # following on from help(esoph)
> model3 <- glm(cbind(ncases, ncontrols) ~ agegp + C(tobgp, , 1) +
+      C(alcgp, , 1), data = esoph, family = binomial())
> summary(model3)

Call:
glm(formula = cbind(ncases, ncontrols) ~ agegp + C(tobgp, , 1) + 
    C(alcgp, , 1), family = binomial(), data = esoph)

Deviance Residuals: 
    Min       1Q   Median       3Q      Max  
-2.3018  -0.7234  -0.2306   0.5737   2.4290  

Coefficients:
                Estimate Std. Error z value Pr(>|z|)    
(Intercept)     -1.15264    0.20326  -5.671 1.42e-08 ***
agegp.L          3.81892    0.67862   5.627 1.83e-08 ***
agegp.Q         -1.49473    0.60671  -2.464   0.0138 *  
agegp.C          0.07923    0.46318   0.171   0.8642    
agegp^4          0.12136    0.32203   0.377   0.7063    
agegp^5         -0.24856    0.21153  -1.175   0.2400    
C(tobgp, , 1).L  0.98287    0.21519   4.568 4.93e-06 ***
C(alcgp, , 1).L  2.38736    0.23462  10.175  < 2e-16 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

(Dispersion parameter for binomial family taken to be 1)

    Null deviance: 367.953  on 87  degrees of freedom
Residual deviance:  91.121  on 80  degrees of freedom
AIC: 222.18

Number of Fisher Scoring iterations: 6

> 
> 
> 
> base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
> ### * <FOOTER>
> ###
> cleanEx()
> options(digits = 7L)
> base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n")
Time elapsed:  16.171 0.554 16.84 0 0 
> grDevices::dev.off()
null device 
          1 
> ###
> ### Local variables: ***
> ### mode: outline-minor ***
> ### outline-regexp: "\\(> \\)?### [*]+" ***
> ### End: ***
> quit('no')