R : Copyright 2005, The R Foundation for Statistical Computing
Version 2.1.0 Under development (unstable) (2005-02-05), ISBN 3-900051-07-0
R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.
R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.
Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for 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)
> ## lm.glm is in ../src/library/utils/man/demo.Rd }:
> dont <- list(graphics = c("Hershey", "Japanese", "plotmath"),
+ stats = c("lm.glm", "nlm")
+ )
> ## don't take tcltk here
> for(pkg in c("base", "graphics", "stats")) {
+
+ 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(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: 1013
Number of builtin functions: 1003
starting with 'is.' : 46
> 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.na : NA
is.name : .
is.nan :
is.null : |
is.numeric : .
is.object : .
is.ordered : .
is.package_version : .
is.pairlist : |
is.primitive : .
is.qr : .
is.real : .
is.recursive : .
is.symbol : .
is.table : .
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.package_version : .
is.pairlist : .
is.primitive : .
is.qr : .
is.real : .
is.recursive : .
is.symbol : .
is.table : .
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.package_version : .
is.pairlist : .
is.primitive : .
is.qr : .
is.real : .
is.recursive : .
is.symbol : .
is.table : .
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.package_version : .
is.pairlist : .
is.primitive : .
is.qr : .
is.real : |
is.recursive : .
is.symbol : .
is.table : .
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.package_version : .
is.pairlist : .
is.primitive : .
is.qr : .
is.real : .
is.recursive : |
is.symbol : .
is.table : .
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.na : NA
is.name : .
is.nan : . . .
is.null : .
is.numeric : .
is.object : |
is.ordered : .
is.package_version : .
is.pairlist : .
is.primitive : .
is.qr : .
is.real : .
is.recursive : |
is.symbol : .
is.table : .
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
FALSE TRUE FALSE FALSE
is.complex is.data.frame is.double is.environment
FALSE FALSE TRUE FALSE
is.expression is.factor is.function is.integer
FALSE FALSE FALSE FALSE
is.language is.list is.logical is.matrix
FALSE FALSE FALSE FALSE
is.name is.null is.numeric is.object
FALSE FALSE TRUE FALSE
is.ordered is.package_version is.pairlist is.primitive
FALSE FALSE FALSE FALSE
is.qr is.real is.recursive is.symbol
FALSE TRUE FALSE FALSE
is.table is.unsorted is.vector
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.package_version : .
is.pairlist : .
is.primitive : .
is.qr : .
is.real : .
is.recursive : .
is.symbol : .
is.table : .
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.package_version : .
is.pairlist : .
is.primitive : .
is.qr : .
is.real : .
is.recursive : |
is.symbol : .
is.table : .
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.na : . . . . . . .
is.name : .
is.nan : . . . . . . .
is.null : .
is.numeric : |
is.object : .
is.ordered : .
is.package_version : .
is.pairlist : .
is.primitive : .
is.qr : .
is.real : .
is.recursive : .
is.symbol : .
is.table : .
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 - 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(graphics)
---- ~~~~~~~~
> if (dev.cur() <= 1) get(getOption("device"))()
> opar <- par(ask = interactive() && (.Device %in% c("X11",
"GTK", "gnome", "windows", "quartz")))
> 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)
> 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)])
> 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")
> 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", "quartz")))
> 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> 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)
})
flld.c> x <- y <- seq(-4 * pi, 4 * pi, len = 27)
flld.c> r <- sqrt(outer(x^2, y^2, "+"))
flld.c> filled.contour(cos(r^2) * exp(-r/(2 * pi)), axes = FALSE)
flld.c> filled.contour(cos(r^2) * exp(-r/(2 * pi)), frame.plot = FALSE,
plot.axes = {
})
> par(opar)
demo(persp)
---- ~~~~~
> if (dev.cur() <= 1) get(getOption("device"))()
> is.dev.interactive <- .Device %in% c("X11", "GTK",
"gnome", "quartz", "windows", "JavaGD")
> 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)
> 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(glm.vr)
---- ~~~~~~
> require(stats)
[1] TRUE
> 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)
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(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> 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: 3.02 0.17 3.19 0 0
>