The R Project SVN
R
(root)/tags/R-1-3/tests/demos.Rout.save – Rev 14768
Rev 14339 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
R : Copyright 2001, The R Development Core TeamVersion 1.3.0 Under development (unstable) (2001-05-24)R is free software and comes with ABSOLUTELY NO WARRANTY.You are welcome to redistribute it under certain conditions.Type `license()' or `licence()' for distribution details.R is a collaborative project with many contributors.Type `contributors()' for more information.Type `demo()' for some demos, `help()' for on-line help, or`help.start()' for a HTML browser interface to help.Type `q()' to quit R.> #### Run all demos that do not depend on tcl and other specials.> .ptime <- proc.time()> .Random.seed <- c(0,rep(7654, 3))>> ## Currently only do `base', but others make sense, not tcltk though :>> ## Drop these for strict testing {and add them to \testonly{.} examples> ## in ../src/library/base/man/demo.Rd }:> dont <- list(base = c("nlm", "lm.glm")+ )> for(pkg in c("base", "eda")) {++ demos <- list.files(file.path(system.file(package = pkg), "demo"),+ pattern = "\\.R$")+ demos <- demos[is.na(match(demos, paste(dont[[pkg]], "R",sep=".")))]++ if(length(demos)) {+ if(need <- pkg != "base" &&+ !any((fpkg <- paste("package", pkg, sep=":")) == search()))+ library(pkg, character.only = TRUE)++ for(nam in sub("\\.R$", "", demos))+ demo(nam, character.only = TRUE)++ if(need) detach(pos = which(fpkg == search()))+ }+ }demo(glm.vr)---- ~~~~~~> Fr <- c(68, 42, 42, 30, 37, 52, 24, 43, 66, 50, 33,23, 47, 55, 23, 47, 63, 53, 29, 27, 57, 49, 19, 29)> Temp <- gl(2, 2, 24, labels = c("Low", "High"))> Soft <- gl(3, 8, 24, labels = c("Hard", "Medium","Soft"))> M.user <- gl(2, 4, 24, labels = c("N", "Y"))> Brand <- gl(2, 1, 24, labels = c("X", "M"))> detg <- data.frame(Fr, Temp, Soft, M.user, Brand)> detg.m0 <- glm(Fr ~ M.user * Temp * Soft + Brand,family = poisson, data = detg)> summary(detg.m0)Call:glm(formula = Fr ~ M.user * Temp * Soft + Brand, family = poisson,data = detg)Deviance Residuals:Min 1Q Median 3Q Max-2.208775 -0.991898 -0.001264 0.935415 1.975997Coefficients:Estimate Std. Error z value Pr(>|z|)(Intercept) 4.01524 0.10032 40.025 < 2e-16 ***M.userY -0.21184 0.14256 -1.486 0.13727TempHigh -0.42381 0.15158 -2.796 0.00517 **SoftMedium 0.05311 0.13307 0.399 0.68982SoftSoft 0.05311 0.13307 0.399 0.68982BrandM -0.01587 0.06299 -0.252 0.80103M.userY:TempHigh 0.13987 0.22163 0.631 0.52798M.userY:SoftMedium 0.08323 0.19684 0.423 0.67243M.userY:SoftSoft 0.12169 0.19590 0.621 0.53447TempHigh:SoftMedium -0.30442 0.22238 -1.369 0.17101TempHigh:SoftSoft -0.30442 0.22238 -1.369 0.17102M.userY:TempHigh:SoftMedium 0.21189 0.31569 0.671 0.50209M.userY:TempHigh:SoftSoft -0.20387 0.32536 -0.627 0.53092---Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1(Dispersion parameter for poisson family taken to be 1)Null deviance: 118.627 on 23 degrees of freedomResidual deviance: 32.826 on 11 degrees of freedomAIC: 191.24Number of Fisher Scoring iterations: 3> detg.mod <- glm(terms(Fr ~ M.user * Temp * Soft +Brand * M.user * Temp, keep.order = TRUE), family = poisson,data = detg)> summary(detg.mod, correlation = FALSE)Call:glm(formula = terms(Fr ~ M.user * Temp * Soft + Brand * M.user *Temp, keep.order = TRUE), family = poisson, data = detg)Deviance Residuals:Min 1Q Median 3Q Max-0.913649 -0.355846 0.002531 0.330274 0.921460Coefficients:Estimate Std. Error z value Pr(>|z|)(Intercept) 4.14887 0.10603 39.128 <2e-16 ***M.userY -0.40521 0.16188 -2.503 0.0123 *TempHigh -0.44275 0.17121 -2.586 0.0097 **M.userY:TempHigh -0.12692 0.26257 -0.483 0.6288SoftMedium 0.05311 0.13308 0.399 0.6898SoftSoft 0.05311 0.13308 0.399 0.6898M.userY:SoftMedium 0.08323 0.19685 0.423 0.6725M.userY:SoftSoft 0.12169 0.19591 0.621 0.5345TempHigh:SoftMedium -0.30442 0.22239 -1.369 0.1710TempHigh:SoftSoft -0.30442 0.22239 -1.369 0.1710M.userY:TempHigh:SoftMedium 0.21189 0.31577 0.671 0.5022M.userY:TempHigh:SoftSoft -0.20387 0.32540 -0.627 0.5310BrandM -0.30647 0.10942 -2.801 0.0051 **M.userY:BrandM 0.40757 0.15961 2.554 0.0107 *TempHigh:BrandM 0.04411 0.18463 0.239 0.8112M.userY:TempHigh:BrandM 0.44427 0.26673 1.666 0.0958 .---Signif. codes: 0 `***' 0.001 `**' 0.01 `*' 0.05 `.' 0.1 ` ' 1(Dispersion parameter for poisson family taken to be 1)Null deviance: 118.627 on 23 degrees of freedomResidual deviance: 5.656 on 8 degrees of freedomAIC: 170.07Number of Fisher Scoring iterations: 3> symnum(summary(detg.mod, correlation = TRUE)$corr)( M.sY TmH M.sY:TH SM SS M.Y:SM M.Y:SS TH:SM TH:SS(Intercept) 1M.userY , 1TempHigh , . 1M.userY:TempHigh . , , 1SoftMedium , . . 1SoftSoft , . . . 1M.userY:SoftMedium . , . , . 1M.userY:SoftSoft . , . . , . 1TempHigh:SoftMedium . , . . . . 1TempHigh:SoftSoft . , . . . . . 1M.userY:TempHigh:SoftMedium . . . . , . , .M.userY:TempHigh:SoftSoft . . . . . , . ,BrandM .M.userY:BrandM .TempHigh:BrandM . .M.userY:TempHigh:BrandM . .M.Y:TH:SM M.Y:TH:SS B M.Y:B TH:B M.Y:TH:B(Intercept)M.userYTempHighM.userY:TempHighSoftMediumSoftSoftM.userY:SoftMediumM.userY:SoftSoftTempHigh:SoftMediumTempHigh:SoftSoftM.userY:TempHigh:SoftMedium 1M.userY:TempHigh:SoftSoft . 1BrandM 1M.userY:BrandM , 1TempHigh:BrandM . . 1M.userY:TempHigh:BrandM . . , 1attr(,"legend")[1] 0 ` ' 0.3 `.' 0.6 `,' 0.8 `+' 0.9 `*' 0.95 `B' 1> anova(detg.m0, detg.mod)Analysis of Deviance TableModel 1: Fr ~ M.user * Temp * Soft + BrandModel 2: Fr ~ M.user + Temp + M.user:Temp + Soft + M.user:Soft + Temp:Soft +M.user:Temp:Soft + Brand + M.user:Brand + Temp:Brand + M.user:Temp:BrandResid. Df Resid. Dev Df Deviance1 11 32.8262 8 5.656 3 27.170demo(graphics)---- ~~~~~~~~> if (dev.cur() <= 1) get(getOption("device"))()> opar <- par(ask = interactive() && (.Device %in% c("X11","GTK", "windows", "Macintosh")))> x <- rnorm(50)> opar <- c(opar, par(bg = "white"))> plot(x, ann = FALSE, type = "n")> abline(h = 0, col = gray(0.9))> lines(x, col = "green4", lty = "dotted")> points(x, bg = "limegreen", pch = 21)> title(main = "Simple Use of Color In a Plot", xlab = "Just a Whisper of a Label",col.main = "blue", col.lab = gray(0.8), cex.main = 1.2, cex.lab = 1,font.main = 4, font.lab = 3)> par(bg = "gray")> piechart(rep(1, 24), col = rainbow(24), radius = 0.9)> title(main = "A Sample Color Wheel", cex.main = 1.4,font.main = 3)> title(xlab = "(Use this as a test of monitor linearity)",cex.lab = 0.8, font.lab = 3)> pie.sales <- c(0.12, 0.3, 0.26, 0.16, 0.04, 0.12)> names(pie.sales) <- c("Blueberry", "Cherry", "Apple","Boston Cream", "Other", "Vanilla Cream")> piechart(pie.sales, col = c("purple", "violetred1","green3", "cornsilk", "cyan", "white"))> title(main = "January Pie Sales", cex.main = 1.8,font.main = 1)> title(xlab = "(Don't try this at home kids)", cex.lab = 0.8,font.lab = 3)> par(bg = "cornsilk")> n <- 10> g <- gl(n, 100, n * 100)> x <- rnorm(n * 100) + sqrt(codes(g))> boxplot(split(x, g), col = "lavender", notch = TRUE)> title(main = "Notched Boxplots", xlab = "Group", font.main = 4,font.lab = 1)> par(bg = "white")> n <- 100> x <- c(0, cumsum(rnorm(n)))> y <- c(0, cumsum(rnorm(n)))> xx <- c(0:n, n:0)> yy <- c(x, rev(y))> plot(xx, yy, type = "n", xlab = "Time", ylab = "Distance")> polygon(xx, yy, col = "gray")> title("Distance Between Brownian Motions")> x <- c(0, 0.4, 0.86, 0.85, 0.69, 0.48, 0.54, 1.09,1.11, 1.73, 2.05, 2.02)> par(bg = "lightgray")> plot(x, type = "n", axes = FALSE, ann = FALSE)> usr <- par("usr")> rect(usr[1], usr[3], usr[2], usr[4], col = "cornsilk",border = "black")> lines(x, col = "blue")> points(x, pch = 21, bg = "lightcyan", cex = 1.25)> axis(2, col.axis = "blue", las = 1)> axis(1, at = 1:12, lab = month.abb, col.axis = "blue")> box()> title(main = "The Level of Interest in R", font.main = 4,col.main = "red")> title(xlab = "1996", col.lab = "red")> par(bg = "cornsilk")> x <- rnorm(1000)> hist(x, xlim = range(-4, 4, x), col = "lavender",main = "")> title(main = "1000 Normal Random Variates", font.main = 3)> data("iris")> pairs(iris[1:4], main = "Edgar Anderson's Iris Data",font.main = 4, pch = 19)> pairs(iris[1:4], main = "Edgar Anderson's Iris Data",pch = 21, bg = c("red", "green3", "blue")[codes(iris$Species)])> data("volcano")> x <- 10 * 1:nrow(volcano)> y <- 10 * 1:ncol(volcano)> l <- pretty(range(volcano), 10)> par(bg = "lightcyan")> pin <- par("pin")> xdelta <- diff(range(x))> ydelta <- diff(range(y))> xscale <- pin[1]/xdelta> yscale <- pin[2]/ydelta> scale <- if (xscale < yscale) xscale else yscale> xadd <- 0.5 * (pin[1]/scale - xdelta)> yadd <- 0.5 * (pin[2]/scale - ydelta)> plot(numeric(0), numeric(0), xlim = range(x) + c(-1,1) * xadd, ylim = range(y) + c(-1, 1) * yadd, type = "n",ann = FALSE)> usr <- par("usr")> rect(usr[1], usr[3], usr[2], usr[4], col = "green3")> contour(x, y, volcano, levels = l, col = "yellow",lty = "solid", add = TRUE)> box()> title("A Topographic Map of Maunga Whau", font = 4)> title(xlab = "Meters North", ylab = "Meters West",font = 3)> mtext("10 Meter Contour Spacing", side = 3, line = 0.35,outer = FALSE, at = mean(par("usr")[1:2]), cex = 0.7, font = 3)> par(bg = "cornsilk")> data(quakes)> coplot(long ~ lat | depth, data = quakes, pch = 21,bg = "green3")> example(plotmath)pltmth> x <- seq(-4, 4, len = 101)pltmth> y <- cbind(sin(x), cos(x))pltmth> matplot(x, y, type = "l", xaxt = "n", main = expression(paste(plain(sin) *phi, " and ", plain(cos) * phi)), ylab = expression("sin" *phi, "cos" * phi), xlab = expression(paste("Phase Angle ",phi)), col.main = "blue")pltmth> axis(1, at = c(-pi, -pi/2, 0, pi/2, pi), lab = expression(-pi,-pi/2, 0, pi/2, pi))pltmth> plot(1:10, type = "n", xlab = "", ylab = "", main = "plot math & numbers")pltmth> tt <- 1.23pltmth> mtext(substitute(hat(theta) == that, list(that = tt)))pltmth> for (i in 2:9) text(i, i + 1, substitute(list(xi,eta) == group("(", list(x, y), ")"), list(x = i, y = i +1)))pltmth> plot(1:10, 1:10)pltmth> text(4, 9, expression(hat(beta) == (X^t * X)^{-1} * X^t * y))pltmth> text(4, 8.4, "expression(hat(beta) == (X^t * X)^{-1} * X^t * y)",cex = 0.8)pltmth> text(4, 7, expression(bar(x) == sum(frac(x[i], n),i == 1, n)))pltmth> text(4, 6.4, "expression(bar(x) == sum(frac(x[i], n), i==1, n))",cex = 0.8)pltmth> text(8, 5, expression(paste(frac(1, sigma * sqrt(2 *pi)), " ", plain(e)^{frac(-(x - mu)^2, 2 * sigma^2)})), cex = 1.2)pltmth> make.table <- function(nr, nc) {savepar <- par(mar = rep(0, 4), pty = "s")plot(c(0, nc * 2 + 1), c(0, -(nr + 1)), type = "n", xlab = "",ylab = "", axes = FALSE)savepar}pltmth> get.r <- function(i, nr) {i%%nr + 1}pltmth> get.c <- function(i, nr) {i%/%nr + 1}pltmth> draw.title.cell <- function(title, i, nr) {r <- get.r(i, nr)c <- get.c(i, nr)text(2 * c - 0.5, -r, title)rect((2 * (c - 1) + 0.5), -(r - 0.5), (2 * c + 0.5), -(r +0.5))}pltmth> draw.plotmath.cell <- function(expr, i, nr, string = NULL) {r <- get.r(i, nr)c <- get.c(i, nr)if (is.null(string)) {string <- deparse(expr)string <- substr(string, 12, nchar(string) - 1)}text((2 * (c - 1) + .... [TRUNCATED]pltmth> nr <- 20pltmth> nc <- 2pltmth> oldpar <- make.table(nr, nc)pltmth> i <- 0pltmth> draw.title.cell("Arithmetic Operators", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x + y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x - y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x * y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x/y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %+-% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x%/%y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %*% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(-x), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(+x), i, nr)pltmth> i <- i + 1pltmth> draw.title.cell("Sub/Superscripts", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x[i]), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x^2), i, nr)pltmth> i <- i + 1pltmth> draw.title.cell("Juxtaposition", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x * y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(paste(x, y, z)), i,nr)pltmth> i <- i + 1pltmth> draw.title.cell("Lists", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(list(x, y, z)), i, nr)pltmth> i <- i + 1pltmth> i <- 20pltmth> draw.title.cell("Radicals", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(sqrt(x)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(sqrt(x, y)), i, nr)pltmth> i <- i + 1pltmth> draw.title.cell("Relations", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x == y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x != y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x < y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x <= y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x > y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x >= y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %~~% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %=~% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %==% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %prop% y), i, nr)pltmth> i <- i + 1pltmth> draw.title.cell("Typeface", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(plain(x)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(italic(x)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(bold(x)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(bolditalic(x)), i, nr)pltmth> i <- i + 1pltmth> nr <- 20pltmth> nc <- 2pltmth> make.table(nr, nc)$mar[1] 0 0 0 0$pty[1] "s"pltmth> i <- 0pltmth> draw.title.cell("Ellipsis", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(list(x[1], ..., x[n])),i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x[1] + ... + x[n]),i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(list(x[1], cdots, x[n])),i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x[1] + ldots + x[n]),i, nr)pltmth> i <- i + 1pltmth> draw.title.cell("Set Relations", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %subset% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %subseteq% y), i,nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %supset% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %supseteq% y), i,nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %notsubset% y), i,nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %in% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %notin% y), i, nr)pltmth> i <- i + 1pltmth> draw.title.cell("Accents", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(hat(x)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(tilde(x)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(ring(x)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(bar(xy)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(widehat(xy)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(widetilde(xy)), i, nr)pltmth> i <- i + 1pltmth> draw.title.cell("Arrows", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %<->% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %->% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %<-% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %up% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %down% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %<=>% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %=>% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %<=% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %dblup% y), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x %dbldown% y), i, nr)pltmth> i <- i + 1pltmth> draw.title.cell("Symbolic Names", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(Alpha - Omega), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(alpha - omega), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(infinity), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(32 * degree), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(60 * minute), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(30 * second), i, nr)pltmth> i <- i + 1pltmth> nr <- 20pltmth> nc <- 1pltmth> make.table(nr, nc)$mar[1] 0 0 0 0$pty[1] "s"pltmth> i <- 0pltmth> draw.title.cell("Style", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(displaystyle(x)), i,nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(textstyle(x)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(scriptstyle(x)), i,nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(scriptscriptstyle(x)),i, nr)pltmth> i <- i + 1pltmth> draw.title.cell("Spacing", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x ~ ~y), i, nr)pltmth> i <- i + 1pltmth> par(new = TRUE)pltmth> nr <- 10pltmth> nc <- 1pltmth> make.table(nr, nc)$mar[1] 0 0 0 0$pty[1] "s"pltmth> i <- 4pltmth> draw.plotmath.cell(expression(x + phantom(0) + y),i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x + over(1, phantom(0))),i, nr)pltmth> i <- i + 1pltmth> draw.title.cell("Fractions", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(frac(x, y)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(over(x, y)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(atop(x, y)), i, nr)pltmth> i <- i + 1pltmth> nr <- 10pltmth> nc <- 1pltmth> make.table(nr, nc)$mar[1] 0 0 0 0$pty[1] "s"pltmth> i <- 0pltmth> draw.title.cell("Big Operators", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(sum(x[i], i = 1, n)),i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(prod(plain(P)(X == x),x)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(integral(f(x) * dx,a, b)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(union(A[i], i == 1,n)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(intersect(A[i], i ==1, n)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(lim(f(x), x %->% 0)),i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(min(g(x), x >= 0)),i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(inf(S)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(sup(S)), i, nr)pltmth> i <- i + 1pltmth> make.table(nr, nc)$mar[1] 0 0 0 0$pty[1] "s"pltmth> i <- 0pltmth> draw.title.cell("Grouping", i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression((x + y) * z), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x^y + z), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x^(y + z)), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(x^{y + z}), i, nr, string = "x^{y + z}")pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(group("(", list(a, b),"]")), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(bgroup("(", atop(x,y), ")")), i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(group(lceil, x, rceil)),i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(group(lfloor, x, rfloor)),i, nr)pltmth> i <- i + 1pltmth> draw.plotmath.cell(expression(group("|", x, "|")),i, nr)pltmth> i <- i + 1pltmth> par(oldpar)> par(opar)demo(image)---- ~~~~~> if (dev.cur() <= 1) get(getOption("device"))()> opar <- par(ask = interactive() && (.Device %in% c("X11","GTK", "windows", "Macintosh")))> data(volcano)> x <- 10 * (1:nrow(volcano))> x.at <- seq(100, 800, by = 100)> y <- 10 * (1:ncol(volcano))> y.at <- seq(100, 600, by = 100)> image(x, y, volcano, col = terrain.colors(100), axes = FALSE)> contour(x, y, volcano, levels = seq(90, 200, by = 5),add = TRUE, col = "brown")> axis(1, at = x.at)> axis(2, at = y.at)> box()> title(main = "Maunga Whau Volcano", sub = "col=terrain.colors(100)",font.main = 4)> image(x, y, volcano, col = heat.colors(100), axes = FALSE)> contour(x, y, volcano, levels = seq(90, 200, by = 5),add = TRUE, col = "brown")> axis(1, at = x.at)> axis(2, at = y.at)> box()> title(main = "Maunga Whau Volcano", sub = "col=heat.colors(100)",font.main = 4)> image(x, y, volcano, col = gray(100:200/200), axes = FALSE)> contour(x, y, volcano, levels = seq(90, 200, by = 5),add = TRUE, col = "black")> axis(1, at = x.at)> axis(2, at = y.at)> box()> title(main = "Maunga Whau Volcano \n col=gray(100:200/200)",font.main = 4)> example(filled.contour)flld.c> data(volcano)flld.c> filled.contour(volcano, color = terrain.colors, asp = 1)flld.c> x <- 10 * 1:nrow(volcano)flld.c> y <- 10 * 1:ncol(volcano)flld.c> filled.contour(x, y, volcano, color = terrain.colors,plot.title = title(main = "The Topography of Maunga Whau",xlab = "Meters North", ylab = "Meters West"), plot.axes = {axis(1, seq(100, 800, by = 100))axis(2, seq(10 .... [TRUNCATED]flld.c> mtext(paste("filled.contour(.) from", R.version.string),side = 1, line = 4, adj = 1, cex = 0.66)flld.c> a <- expand.grid(1:20, 1:20)flld.c> b <- matrix(a[, 1] + a[, 2], 20)flld.c> filled.contour(x = 1:20, y = 1:20, z = b, plot.axes = {axis(1)axis(2)points(10, 10)})> par(opar)demo(is.things)---- ~~~~~~~~~> ls.base <- ls("package:base")> base.is.f <- sapply(ls.base, function(x) is.function(get(x)))> bi <- ls.base[base.is.f]> cat("\nNumber of base objects:\t\t", length(ls.base),"\nNumber of builtin functions:\t", sum(base.is.f), "\n\t starting with 'is.' :\t ",length(is.bi <- bi[substring(bi, 1, 3) == "is."]), "\n")Number of base objects: 1393Number of builtin functions: 1361starting with 'is.' : 41> is.primitive <- function(obj) is.function(obj) &&is.null(args(obj))> is.method <- function(fname) {np <- length(sp <- strsplit(fname, split = "\\.")[[1]])if (np <= 1)return(FALSE)exists(paste(sp[1:(np - 1)], collapse = "."), mode = "function") ||(np >= 3 && exists(paste(sp[1:(np - 2) .... [TRUNCATED]> is.ALL <- function(obj, func.names = ls(pos = length(search())),not.using = c("is.single", "is.loaded", "is.empty.model","is.R", "is.element"), true.only = FALSE, debug = FALSE) {is.fn <- func.names[substring(func.names, 1, 3) == .... [TRUNCATED]> print.isList <- function(r, ...) {if (is.list(r)) {nm <- format(names(r))rr <- lapply(r, symnum, na = "NA")for (i in seq(along = r)) cat(nm[i], ":", rr[[i]], "\n",...)}else NextMethod("print", . .... [TRUNCATED]> is.ALL(NULL)is.array : .is.atomic : |is.call : .is.character : .is.complex : .is.data.frame : .is.double : .is.environment : .is.expression : .is.factor : .is.finite : NAis.function : .is.infinite : ()is.integer : .is.language : .is.list : .is.logical : .is.matrix : .is.na : NAis.name : .is.nan : ()is.null : |is.numeric : .is.object : .is.ordered : .is.pairlist : |is.qr : .is.real : .is.recursive : .is.symbol : .is.table : .is.ts : .is.unsorted : .is.vector : .> is.ALL(NULL, true.only = TRUE)[1] "is.atomic" "is.null" "is.pairlist"> all.equal(NULL, pairlist())[1] TRUE> is.ALL(list(), true.only = TRUE)[1] "is.list" "is.recursive" "is.vector"> (pl <- is.ALL(pairlist(1, list(3, "A")), true.only = TRUE))[1] "is.list" "is.pairlist" "is.recursive"> (ll <- is.ALL(list(1, pairlist(3, "A")), true.only = TRUE))[1] "is.list" "is.recursive" "is.vector"> all.equal(pl[pl != "is.pairlist"], ll[ll != "is.vector"])[1] TRUE> is.ALL(1:5)is.array : .is.atomic : |is.call : .is.character : .is.complex : .is.data.frame : .is.double : .is.environment : .is.expression : .is.factor : .is.finite : | | | | |is.function : .is.infinite : . . . . .is.integer : |is.language : .is.list : .is.logical : .is.matrix : .is.na : . . . . .is.name : .is.nan : . . . . .is.null : .is.numeric : |is.object : .is.ordered : .is.pairlist : .is.qr : .is.real : .is.recursive : .is.symbol : .is.table : .is.ts : .is.unsorted : .is.vector : |> is.ALL(array(1:24, 2:4))is.array : |is.atomic : |is.call : .is.character : .is.complex : .is.data.frame : .is.double : .is.environment : .is.expression : .is.factor : .is.finite : | | | | | | | | | | | | | | | | | | | | | | | |is.function : .is.infinite : . . . . . . . . . . . . . . . . . . . . . . . .is.integer : |is.language : .is.list : .is.logical : .is.matrix : .is.na : . . . . . . . . . . . . . . . . . . . . . . . .is.name : .is.nan : . . . . . . . . . . . . . . . . . . . . . . . .is.null : .is.numeric : |is.object : .is.ordered : .is.pairlist : .is.qr : .is.real : .is.recursive : .is.symbol : .is.table : .is.ts : .is.unsorted : .is.vector : .> is.ALL(1 + 3)is.array : .is.atomic : |is.call : .is.character : .is.complex : .is.data.frame : .is.double : |is.environment : .is.expression : .is.factor : .is.finite : |is.function : .is.infinite : .is.integer : .is.language : .is.list : .is.logical : .is.matrix : .is.na : .is.name : .is.nan : .is.null : .is.numeric : |is.object : .is.ordered : .is.pairlist : .is.qr : .is.real : |is.recursive : .is.symbol : .is.table : .is.ts : .is.unsorted : .is.vector : |> e13 <- expression(1 + 3)> is.ALL(e13)is.array : .is.atomic : .is.call : .is.character : .is.complex : .is.data.frame : .is.double : .is.environment : .is.expression : |is.factor : .is.finite : .is.function : .is.infinite : .is.integer : .is.language : |is.list : .is.logical : .is.matrix : .is.na : .is.name : .is.nan : .is.null : .is.numeric : .is.object : .is.ordered : .is.pairlist : .is.qr : .is.real : .is.recursive : |is.symbol : .is.table : .is.ts : .is.unsorted : NAis.vector : |> is.ALL(substitute(expression(a + 3), list(a = 1)),true.only = TRUE)[1] "is.call" "is.language" "is.recursive"> is.ALL(y ~ x)is.array : .is.atomic : .is.call : |is.character : .is.complex : .is.data.frame : .is.double : .is.environment : .is.expression : .is.factor : .is.finite : NAis.function : .is.infinite : . . .is.integer : .is.language : |is.list : .is.logical : .is.matrix : .is.na : NAis.name : .is.nan : . . .is.null : .is.numeric : .is.object : |is.ordered : .is.pairlist : .is.qr : .is.real : .is.recursive : |is.symbol : .is.table : .is.ts : .is.unsorted : NAis.vector : .> is0 <- is.ALL(numeric(0))> is0.ok <- 1 == (lis0 <- sapply(is0, length))> is0[!is0.ok]$is.finitelogical(0)$is.infinitelogical(0)$is.nalogical(0)$is.nanlogical(0)> is0 <- unlist(is0)> is0is.array is.atomic is.call is.character is.complexFALSE TRUE FALSE FALSE FALSEis.data.frame is.double is.environment is.expression is.factorFALSE TRUE FALSE FALSE FALSEis.function is.integer is.language is.list is.logicalFALSE FALSE FALSE FALSE FALSEis.matrix is.name is.null is.numeric is.objectFALSE FALSE FALSE TRUE FALSEis.ordered is.pairlist is.qr is.real is.recursiveFALSE FALSE FALSE TRUE FALSEis.symbol is.table is.ts is.unsorted is.vectorFALSE FALSE FALSE FALSE TRUE> ispi <- unlist(is.ALL(pi))> all(ispi[is0.ok] == is0)[1] TRUE> is.ALL(numeric(0), true = TRUE)[1] "is.atomic" "is.double" "is.numeric" "is.real" "is.vector"> is.ALL(array(1, 1:3), true = TRUE)[1] "is.array" "is.atomic" "is.double" "is.numeric" "is.real"> is.ALL(cbind(1:3), true = TRUE)[1] "is.array" "is.atomic" "is.integer" "is.matrix" "is.numeric"> is.ALL(structure(1:7, names = paste("a", 1:7, sep = "")))is.array : .is.atomic : |is.call : .is.character : .is.complex : .is.data.frame : .is.double : .is.environment : .is.expression : .is.factor : .is.finite : | | | | | | |is.function : .is.infinite : . . . . . . .is.integer : |is.language : .is.list : .is.logical : .is.matrix : .is.na : . . . . . . .is.name : .is.nan : . . . . . . .is.null : .is.numeric : |is.object : .is.ordered : .is.pairlist : .is.qr : .is.real : .is.recursive : .is.symbol : .is.table : .is.ts : .is.unsorted : .is.vector : |> is.ALL(structure(1:7, names = paste("a", 1:7, sep = "")),true.only = TRUE)[1] "is.atomic" "is.integer" "is.numeric" "is.vector"> x <- 1:20> y <- 5 + 6 * x + rnorm(20)> lm.xy <- lm(y ~ x)> is.ALL(lm.xy)is.array : .is.atomic : .is.call : .is.character : .is.complex : .is.data.frame : .is.double : .is.environment : .is.expression : .is.factor : .is.finite : . . . . . . . . . . . .is.function : .is.infinite : . . . . . . . . . . . .is.integer : .is.language : .is.list : |is.logical : .is.matrix : .is.na : . . . . . . . . . . . .is.name : .is.nan : . . . . . . . . . . . .is.null : .is.numeric : .is.object : |is.ordered : .is.pairlist : .is.qr : .is.real : .is.recursive : |is.symbol : .is.table : .is.ts : .is.unsorted : NAis.vector : .> is.ALL(structure(1:7, names = paste("a", 1:7, sep = "")))is.array : .is.atomic : |is.call : .is.character : .is.complex : .is.data.frame : .is.double : .is.environment : .is.expression : .is.factor : .is.finite : | | | | | | |is.function : .is.infinite : . . . . . . .is.integer : |is.language : .is.list : .is.logical : .is.matrix : .is.na : . . . . . . .is.name : .is.nan : . . . . . . .is.null : .is.numeric : |is.object : .is.ordered : .is.pairlist : .is.qr : .is.real : .is.recursive : .is.symbol : .is.table : .is.ts : .is.unsorted : .is.vector : |> is.ALL(structure(1:7, names = paste("a", 1:7, sep = "")),true.only = TRUE)[1] "is.atomic" "is.integer" "is.numeric" "is.vector"demo(recursion)---- ~~~~~~~~~> area <- function(f, a, b, ..., fa = f(a, ...), fb = f(b,...), limit = 10, eps = 1e-05) {h <- b - ad <- (a + b)/2fd <- f(d, ...)a1 <- ((fa + fb) * h)/2a2 <- ((fa + 4 * fd + fb) * h)/6if (abs(a1 - a2) < eps).... [TRUNCATED]> fbeta <- function(x, alpha, beta) {x^(alpha - 1) * (1 - x)^(beta - 1)}> b0 <- area(fbeta, 0, 1, alpha = 3.5, beta = 1.5)> b1 <- exp(lgamma(3.5) + lgamma(1.5) - lgamma(5))> c(b0, b1, b0 - b1)[1] 1.227170e-01 1.227185e-01 -1.443996e-06> fbeta.tmp <- function(x, alpha, beta) {val <<- c(val, x)x^(alpha - 1) * (1 - x)^(beta - 1)}> val <- NULL> b0 <- area(fbeta.tmp, 0, 1, alpha = 3.5, beta = 1.5)> plot(val, fbeta(val, 3.5, 1.5), pch = 0)> area <- function(f, a, b, ..., limit = 10, eps = 1e-05) {area2 <- function(f, a, b, ..., fa = f(a, ...), fb = f(b,...), limit = limit, eps = eps) {h <- b - ad <- (a + b)/2fd <- f(d, ...)a1 <- ((fa + .... [TRUNCATED]demo(scoping)---- ~~~~~~~> open.account <- function(total) {list(deposit = function(amount) {if (amount <= 0) stop("Deposits must be positive!\n")total <<- total + amountcat(amount, "deposited. Your balance is", total, "\n\n")}, withdraw = .... [TRUNCATED]> ross <- open.account(100)> robert <- open.account(200)> ross$withdraw(30)30 withdrawn. Your balance is 70> ross$balance()Your balance is 70> robert$balance()Your balance is 200> ross$deposit(50)50 deposited. Your balance is 120> ross$balance()Your balance is 120> try(ross$withdraw(500))Error in ross$withdraw(500) : You don't have that much money!In addition: Warning messages:1: is.nan() applied to non-(list or vector) in: fn(obj)2: is.nan() applied to non-(list or vector) in: fn(obj)3: is.na() applied to non-(list or vector) in: fn(obj)4: is.nan() applied to non-(list or vector) in: fn(obj)5: is.nan() applied to non-(list or vector) in: fn(obj)6: is.nan() applied to non-(list or vector) in: fn(obj)demo(smooth)---- ~~~~~~> op <- par(ask = interactive(), mfrow = c(1, 1))> example(smooth)smooth> x1 <- c(4, 1, 3, 6, 6, 4, 1, 6, 2, 4, 2)smooth> (x3R <- smooth(x1, "3R"))3R Tukey smoother resulting from smooth(x = x1, kind = "3R")used 2 iterations[1] 3 3 3 6 6 4 4 4 2 2 2smooth> 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 2smooth> sm.3RS <- function(x, ...) smooth(smooth(x, "3R",...), "S", ...)smooth> y <- c(1, 1, 19:1)smooth> plot(y, main = "misbehaviour of \"3RSR\"", col.main = 3)smooth> lines(sm.3RS(y))smooth> lines(smooth(y))smooth> lines(smooth(y, "3RSR"), col = 3, lwd = 2)smooth> x <- c(8:10, 10, 0, 0, 9, 9)smooth> plot(x, main = "breakdown of 3R and S and hence 3RSS")smooth> matlines(cbind(smooth(x, "3R"), smooth(x, "S"), smooth(x,"3RSS"), smooth(x)))smooth> data(presidents)smooth> presidents[is.na(presidents)] <- 0smooth> summary(sm3 <- smooth(presidents, "3R"))3R Tukey smoother resulting fromsmooth(x = presidents, kind = "3R") ; n = 120used 4 iterationsMin. 1st Qu. Median Mean 3rd Qu. Max.0.0 44.0 57.0 54.2 71.0 82.0smooth> summary(sm2 <- smooth(presidents, "3RSS"))3RSS Tukey smoother resulting fromsmooth(x = presidents, kind = "3RSS") ; n = 120used 5 iterationsMin. 1st Qu. Median Mean 3rd Qu. Max.0.00 44.00 57.00 55.45 69.00 82.00smooth> summary(sm <- smooth(presidents))3RS3R Tukey smoother resulting fromsmooth(x = presidents) ; n = 120used 7 iterationsMin. 1st Qu. Median Mean 3rd Qu. Max.24.00 44.00 57.00 55.88 69.00 82.00smooth> all.equal(c(sm2), c(smooth(smooth(sm3, "S"), "S")))[1] TRUEsmooth> all.equal(c(sm), c(smooth(smooth(sm3, "S"), "3R")))[1] TRUEsmooth> plot(presidents, main = "smooth(presidents0, *) : 3R and default 3RS3R")smooth> lines(sm3, col = 3, lwd = 1.5)smooth> lines(sm, col = 2, lwd = 1.25)> showSmooth <- function(x, leg.x = 1, leg.y = max(x)) {ss <- cbind(x, "3c" = smooth(x, "3", end = "copy"), "3" = smooth(x,"3"), "3Rc" = smooth(x, "3R", end = "copy"), "3R" = smooth(x,"3R"), sm = smooth(x))k <- ncol(ss) - .... [TRUNCATED]> for (x in list(c(4, 6, 2, 2, 6, 3, 6, 6, 5, 2), c(3,2, 1, 4, 5, 1, 3, 2, 4, 5, 2), c(2, 4, 2, 6, 1, 1, 2, 6,3, 1, 6), x1, )) print(t(showSmooth(x)))[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]x 4 6 2 2 6 3 6 6 5 23c 4 4 2 2 3 6 6 6 5 23 4 4 2 2 3 6 6 6 5 33Rc 4 4 2 2 3 6 6 6 5 23R 4 4 2 2 3 6 6 6 5 3sm 4 4 4 3 3 6 6 6 5 3[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11]x 3 2 1 4 5 1 3 2 4 5 23c 3 2 2 4 4 3 2 3 4 4 23 2 2 2 4 4 3 2 3 4 4 43Rc 3 2 2 4 4 3 3 3 4 4 23R 2 2 2 4 4 3 3 3 4 4 4sm 2 2 2 2 3 3 3 3 4 4 4[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11]x 2 4 2 6 1 1 2 6 3 1 63c 2 2 4 2 1 1 2 3 3 3 63 2 2 4 2 1 1 2 3 3 3 33Rc 2 2 2 2 1 1 2 3 3 3 63R 2 2 2 2 1 1 2 3 3 3 3sm 2 2 2 2 2 2 2 3 3 3 3[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11]x 4 1 3 6 6 4 1 6 2 4 23c 4 3 3 6 6 4 4 2 4 2 23 3 3 3 6 6 4 4 2 4 2 23Rc 4 3 3 6 6 4 4 4 2 2 23R 3 3 3 6 6 4 4 4 2 2 2sm 3 3 3 3 4 4 4 4 2 2 2> par(op)>> cat("Time elapsed: ", proc.time() - .ptime, "\n")Time elapsed: 8.71 0.12 8.94 0 0>