R : Copyright 2003, The R Development Core Team Version 1.8.0 Under development (unstable) (2003-05-12) 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)) > > ## Drop these for strict testing {and add them to demos2.R) > ## in ../src/library/base/man/demo.Rd }: > dont <- list(base = c("Hershey", "Japanese", "lm.glm", "nlm", "plotmath") + ) > ## don't take tcltk here > 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.208764 -0.991898 -0.001264 0.935415 1.976008 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) 4.01524 0.10034 40.018 < 2e-16 *** M.userY -0.21184 0.14257 -1.486 0.13731 TempHigh -0.42381 0.15159 -2.796 0.00518 ** SoftMedium 0.05311 0.13308 0.399 0.68984 SoftSoft 0.05311 0.13308 0.399 0.68984 BrandM -0.01587 0.06300 -0.252 0.80106 M.userY:TempHigh 0.13987 0.22168 0.631 0.52806 M.userY:SoftMedium 0.08323 0.19685 0.423 0.67245 M.userY:SoftSoft 0.12169 0.19591 0.621 0.53449 TempHigh:SoftMedium -0.30442 0.22239 -1.369 0.17104 TempHigh:SoftSoft -0.30442 0.22239 -1.369 0.17104 M.userY:TempHigh:SoftMedium 0.21189 0.31577 0.671 0.50220 M.userY:TempHigh:SoftSoft -0.20387 0.32540 -0.627 0.53098 --- 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 freedom Residual deviance: 32.826 on 11 degrees of freedom AIC: 191.24 Number of Fisher Scoring iterations: 4 > 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.921460 Coefficients: 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.6288 SoftMedium 0.05311 0.13308 0.399 0.6898 SoftSoft 0.05311 0.13308 0.399 0.6898 M.userY:SoftMedium 0.08323 0.19685 0.423 0.6725 M.userY:SoftSoft 0.12169 0.19591 0.621 0.5345 TempHigh:SoftMedium -0.30442 0.22239 -1.369 0.1710 TempHigh:SoftSoft -0.30442 0.22239 -1.369 0.1710 M.userY:TempHigh:SoftMedium 0.21189 0.31577 0.671 0.5022 M.userY:TempHigh:SoftSoft -0.20387 0.32540 -0.627 0.5310 BrandM -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.8112 M.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 freedom Residual deviance: 5.656 on 8 degrees of freedom AIC: 170.07 Number of Fisher Scoring iterations: 4 > 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) 1 M.userY , 1 TempHigh , . 1 M.userY:TempHigh . , , 1 SoftMedium , . . 1 SoftSoft , . . . 1 M.userY:SoftMedium . , . , . 1 M.userY:SoftSoft . , . . , . 1 TempHigh:SoftMedium . , . . . . 1 TempHigh:SoftSoft . , . . . . . 1 M.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.userY TempHigh M.userY:TempHigh SoftMedium SoftSoft M.userY:SoftMedium M.userY:SoftSoft TempHigh:SoftMedium TempHigh:SoftSoft M.userY:TempHigh:SoftMedium 1 M.userY:TempHigh:SoftSoft . 1 BrandM 1 M.userY:BrandM , 1 TempHigh:BrandM . . 1 M.userY:TempHigh:BrandM . . , 1 attr(,"legend") [1] 0 ` ' 0.3 `.' 0.6 `,' 0.8 `+' 0.9 `*' 0.95 `B' 1 > anova(detg.m0, detg.mod) Analysis of Deviance Table Model 1: Fr ~ M.user * Temp * Soft + Brand Model 2: Fr ~ M.user * Temp * Soft + Brand * M.user * Temp Resid. Df Resid. Dev Df Deviance 1 11 32.826 2 8 5.656 3 27.170 demo(graphics) ---- ~~~~~~~~ > if (dev.cur() <= 1) get(getOption("device"))() > opar <- par(ask = interactive() && (.Device %in% c("X11", "GTK", "gnome", "windows"))) > 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") > pie(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") > pie(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(as.numeric(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")[unclass(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(lat ~ long | depth, data = quakes, pch = 21, bg = "green3") > par(opar) demo(image) ---- ~~~~~ > if (dev.cur() <= 1) get(getOption("device"))() > opar <- par(ask = interactive() && (.Device %in% c("X11", "GTK", "windows"))) > 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: 1632 Number of builtin functions: 1599 starting with 'is.' : 45 > is.primitive <- function(obj) is.function(obj) && is.null(args(obj)) > is.method <- function(fname) { isFun <- function(name) (exists(name, mode = "function") && is.na(match(name, c("is", "as")))) np <- length(sp <- strsplit(fname, split = "\\.")[[1]]) if (np <= 1) FALSE else (isFun(pas .... [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(x, ..., verbose = getOption("verbose")) { if (is.list(x)) { if (verbose) cat("print.isList(): list case (length=", length(x), ")\n") nm <- format(names(x)) rr <- lappl .... [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 : NA is.function : . is.infinite : () is.integer : . is.language : . is.list : . is.logical : . is.matrix : . is.mts : . is.na : 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(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.mts : . 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.mts : . 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.mts : . 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.mts : . 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 : NA is.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 : NA is.function : . is.infinite : . . . is.integer : . is.language : | is.list : . is.logical : . is.matrix : . is.mts : . is.na : 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 : NA is.vector : . > is0 <- is.ALL(numeric(0)) > is0.ok <- 1 == (lis0 <- sapply(is0, length)) > is0[!is0.ok] $is.finite logical(0) $is.infinite logical(0) $is.na logical(0) $is.nan logical(0) > is0 <- unlist(is0) > is0 is.array is.atomic is.call is.character is.complex FALSE TRUE FALSE FALSE FALSE is.data.frame is.double is.environment is.expression is.factor FALSE TRUE FALSE FALSE FALSE is.function is.integer is.language is.list is.logical FALSE FALSE FALSE FALSE FALSE is.matrix is.mts is.name is.null is.numeric FALSE FALSE FALSE FALSE TRUE is.object is.ordered is.pairlist is.qr is.real FALSE FALSE FALSE FALSE TRUE is.recursive is.symbol is.table is.ts is.unsorted FALSE FALSE FALSE FALSE FALSE is.vector 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.mts : . 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.mts : . 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 : NA is.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.mts : . 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(persp) ---- ~~~~~ > is.dev.interactive <- eval(body(dev.interactive)[[3]]) > op <- par(ask = is.dev.interactive) > x <- seq(-10, 10, length = 50) > y <- x > rotsinc <- function(x, y) { sinc <- function(x) { y <- sin(x)/x y[is.na(y)] <- 1 y } 10 * sinc(sqrt(x^2 + y^2)) } > sinc.exp <- expression(z == Sinc(sqrt(x^2 + y^2))) > z <- outer(x, y, rotsinc) > par(bg = "white") > persp(x, y, z, theta = 30, phi = 30, expand = 0.5, col = "lightblue") > title(sub = ".") > title(main = sinc.exp) > persp(x, y, z, theta = 30, phi = 30, expand = 0.5, col = "lightblue", ltheta = 120, shade = 0.75, ticktype = "detailed", xlab = "X", ylab = "Y", zlab = "Z") > title(sub = ".") > title(main = sinc.exp) > data(volcano) > z <- 2 * volcano > x <- 10 * (1:nrow(z)) > y <- 10 * (1:ncol(z)) > persp(x, y, z, theta = 120, phi = 15, scale = FALSE, axes = FALSE) > z0 <- min(z) - 20 > z <- rbind(z0, cbind(z0, z, z0), z0) > x <- c(min(x) - 1e-10, x, max(x) + 1e-10) > y <- c(min(y) - 1e-10, y, max(y) + 1e-10) > fill <- matrix("green3", nr = nrow(z) - 1, nc = ncol(z) - 1) > fill[, i2 <- c(1, ncol(fill))] <- "gray" > fill[i1 <- c(1, nrow(fill)), ] <- "gray" > par(bg = "lightblue") > persp(x, y, z, theta = 120, phi = 15, col = fill, scale = FALSE, axes = FALSE) > title(main = "Maunga Whau\nOne of 50 Volcanoes in the Auckland Region.", font.main = 4) > par(bg = "slategray") > persp(x, y, z, theta = 135, phi = 30, col = fill, scale = FALSE, ltheta = -120, lphi = 15, shade = 0.65, axes = FALSE) > persp(x, y, z, theta = 135, phi = 30, col = "green3", scale = FALSE, ltheta = -120, shade = 0.75, border = NA, box = FALSE) > fcol <- fill > fcol[] <- terrain.colors(nrow(fcol)) > persp(x, y, z, theta = 135, phi = 30, col = fcol, scale = FALSE, ltheta = -120, shade = 0.3, border = NA, box = FALSE) > fcol <- fill > zi <- volcano[-1, -1] + volcano[-1, -61] + volcano[-87, -1] + volcano[-87, -61] > fcol[-i1, -i2] <- terrain.colors(20)[cut(zi, quantile(zi, seq(0, 1, len = 21)), include.lowest = TRUE)] > persp(x, y, 2 * z, theta = 110, phi = 40, col = fcol, scale = FALSE, ltheta = -120, shade = 0.4, border = NA, box = FALSE) > par(op) demo(recursion) ---- ~~~~~~~~~ > area <- function(f, a, b, ..., fa = f(a, ...), fb = f(b, ...), limit = 10, eps = 1e-05) { h <- b - a d <- (a + b)/2 fd <- f(d, ...) a1 <- ((fa + fb) * h)/2 a2 <- ((fa + 4 * fd + fb) * h)/6 if (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 - a d <- (a + b)/2 fd <- 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 + amount cat(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 2 smooth> 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 smooth> 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)] <- 0 smooth> 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 smooth> 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 smooth> 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 smooth> all.equal(c(sm2), c(smooth(smooth(sm3, "S"), "S"))) [1] TRUE smooth> all.equal(c(sm), c(smooth(smooth(sm3, "S"), "3R"))) [1] TRUE smooth> 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 2 3c 4 4 2 2 3 6 6 6 5 2 3 4 4 2 2 3 6 6 6 5 3 3Rc 4 4 2 2 3 6 6 6 5 2 3R 4 4 2 2 3 6 6 6 5 3 sm 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 2 3c 3 2 2 4 4 3 2 3 4 4 2 3 2 2 2 4 4 3 2 3 4 4 4 3Rc 3 2 2 4 4 3 3 3 4 4 2 3R 2 2 2 4 4 3 3 3 4 4 4 sm 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 6 3c 2 2 4 2 1 1 2 3 3 3 6 3 2 2 4 2 1 1 2 3 3 3 3 3Rc 2 2 2 2 1 1 2 3 3 3 6 3R 2 2 2 2 1 1 2 3 3 3 3 sm 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 2 3c 4 3 3 6 6 4 4 2 4 2 2 3 3 3 3 6 6 4 4 2 4 2 2 3Rc 4 3 3 6 6 4 4 4 2 2 2 3R 3 3 3 6 6 4 4 4 2 2 2 sm 3 3 3 3 4 4 4 4 2 2 2 > par(op) > > cat("Time elapsed: ", proc.time() - .ptime, "\n") Time elapsed: 2.73 0.12 2.91 0 0 >