`g2.1` <- function(device="", path="~/r-book/ed2/Art/") { if(device!="")hardcopy(width=5.5, height=2, path=path, device=device) oldpar <- par(mar=c(4.1,3.6,3.1,0.4), mgp=c(2.5,0.75,0)) on.exit(par(oldpar)) library(DAAG) data(possum) attach(possum) here <- sex == "f" dens <- density(totlngth[here]) xlim <- range(dens$x) ylim <- range(dens$y) par(fig=c(0,0.26,0,1)) hist(totlngth[here], breaks = 72.5 + (0:5) * 5, xlim=xlim, ylim = c(0, 22), xlab="Total length (cm)", main="") mtext(side=3, line=2.1, "A", at=67.5, cex=1.15) mtext(side=3, line=0.8, text ="Breaks at 72.5, 77.5, ...") par(fig=c(0.22,0.48,0,1), new=TRUE) hist(totlngth[here], breaks = 75 + (0:5) * 5, xlim=xlim, ylab="", ylim = c(0, 22), xlab="Total length (cm)", yaxt="n", main="") mtext(side=3, line=2.1, "B", at=67.5, cex=1.15) mtext(side=3, line=0.8, text="Breaks at 75, 80, ...") par(fig=c(0.52, 0.78,0,1), new=TRUE) hist(totlngth[here], breaks = 72.5 + (0:5) * 5, freq=F, probability = T, xlim = xlim, ylim = ylim, xlab="Total length (cm)", main="") mtext(side=3, line=2.1, "C", at=67.5, cex=1.15) mtext(side=3, line=0.8, text="Breaks as in A", at=81) lines(dens) par(fig=c(0.74,1,0,1), new=TRUE) hist(totlngth[here], breaks = 75 + (0:5) * 5, freq=F, probability = T, xlim = xlim, ylim = ylim, yaxt="n", xlab="Total length (cm)", ylab="", main="") mtext(side=3, line=2.1, "D", at=67.5, cex=1.15) mtext(side=3, line=0.8, text="Breaks as in B", at=81) lines(dens) detach("possum") if(device!="")dev.off() invisible() } `g2.10` <- function(device="", pointsize=c(8,4)){ library(DAAG) if(device!="")hardcopy(width=5.5, height=3.25, pointsize=pointsize, device=device, trellis=T, color=T) par(fig=c(0, 0.525, 0, 1)) plot.new() mtext(side=3, line=2.5, "A", adj=-0.225, cex=0.75) par(fig=c(0.455, 1, 0, 1), new=TRUE) mtext(side=3, line=2.5, "B", adj=-0.225, cex=0.75) colr <- c("gray40","black") plotchar <- c(1, 16) targplot <- xyplot(csoa ~ it|sex*agegp, data=tinting, groups=target, col=colr, pch=plotchar, key=list(space="top", columns=2, points=list(pch=plotchar, col=colr), text=list(levels(tinting$target))), scale=list(y=list(alternating=1))) print(targplot, position=c(0, 0, 0.525, 1), newpage=FALSE) colr <- c("skyblue1", "skyblue4")[c(2,1,2)] plotchar <- c(1,16,16) # open, filled, filled u <- xyplot(csoa~it|sex*agegp, data=tinting, groups=tint, col=colr, pch=plotchar, type=c("p","smooth"), span=1.25, key=list(space="top", columns=3, points=list(pch=c(1,16,16), col=colr), text=list(levels(tinting$tint), col=colr)), scale=list(y=list(alternating=2)), ylab="") print(u, position=c(0.475, 0, 1, 1), newpage=FALSE) if(device!="")dev.off() } `g2.11` <- function(device=""){ if(device!="")hardcopy(width=2.25, height=2.25, pointsize=8, device=device) oldpar <- par(mar=c(2.1,2.1, 1.1, 1.1), xpd=TRUE) on.exit(par(oldpar)) stones <- array(c(81,6,234,36,192,71,55,25), dim=c(2,2,2), dimnames=list(Sucess=c("yes","no"), Method=c("open","ultrasound"), Size=c("<2cm\n", ">=2cm\n"))) library(vcd) # vcd must be installed mosaicplot(aperm(stones, 3:1), cex.axis=0.65, main="", off=c(4,5,6)) if(device!="")dev.off() } `g2.12` <- function(device="", pointsize=c(9,6)) { if(device!=""){hardcopy(width=5, height=2.25, trellis=T, color=F, pointsize=pointsize, device=device) } oldpar <- par(mar = par()$mar + c(0, 3, -2.5, 0)) on.exit(par(oldpar)) library(DAAG) kiwishade$block <- factor(kiwishade$block, levels=c("west","north","east")) gph <- dotplot(shade~yield | block, data=kiwishade, pch=1, col="black", panel=function(x,y,...){panel.dotplot(x, y, ...) av <- sapply(split(x,y), mean); ypos <- unique(y) lpoints(ypos ~ av, pch=3, cex=1.25, col="black") }, key=list(space="top", columns=2, text=list(c("Individual vine yields", "Plot means (4 vines)"), cex=1), points=list(pch=c(1, 3), cex=c(1,1.25))), layout=c(3,1), aspect=1) print(gph) if(device!="")dev.off() invisible() } `g2.13` <- function(device="", seed=21) { if(!is.null(seed))set.seed(seed) if(device!="")hardcopy(width=4.5, height=1.25, device=device) titl <- paste("Different relationships between y and x.", sep = "") x1 <- x2 <- x3 <- (11:30)/5 y1 <- x1 + rnorm(20)/2 y2 <- 2 - 0.05 * x1 + 0.1 * ((x1 - 1.75))^4 + 1.25 * rnorm(20) r <- round(cor(x1, y2), 3) rho <- round(cor(rank(x1), rank(y2)), 3) print(c(r, rho)) y3 <- (x1 - 3.85)^2 + 0.015 + rnorm(20)/4 theta <- ((2 * pi) * (1:20))/20 x4 <- 10 + 4 * cos(theta) y4 <- 10 + 4 * sin(theta) + (0.5 * rnorm(20)) r1 <- cor(x1, y1) xy <- data.frame(x = c(rep(x1, 3), x4), y = c(y1, y2, y3, y4), gp = rep(1:4, rep(20, 4))) xy<-split(xy,xy$gp) xlimdf<-lapply(list(x1,x2,x3,x4),range) ylimdf<-lapply(list(y1,y2,y3,y4),range) xy<-lapply(1:4,function(i,u,v,w){list(xlim=v[[i]], ylim=w[[i]], x=u[[i]]$x, y=u[[i]]$y)}, u=xy,v=xlimdf,w=ylimdf) panel.corr<-function(data,...){ x<-data$x y<-data$y points(x, y, pch = 16) chh <- par()$cxy[2] x1 <- min(x) y1 <- max(y) - chh/8 r1 <- cor(x, y) text(x1, y1, paste(round(r1, 3)), cex = 1.0, adj = 0) } panelplot(xy,panel=panel.corr,totrows=1,totcols=4, oma=rep(1,4)) titl <- paste(titl, " In the lower right \npanel, the ", "Pearson correlation is ", r, ", while the Spearman rank \ncorrelation is ", rho, ".", sep = "") if(device!="")dev.off() par(mfrow=c(1,1)) invisible() } `g2.2` <- function(width=4.25, height=2.25, pointsize=c(7,4), device=""){ if(device!="") hardcopy(width=width, height=height, trellis=T, color=F, pointsize=pointsize, device=device) library(DAAG) data(possum) gph <- densityplot(~earconch | Pop, groups=sex, data=possum, auto.key=list(columns=2), aspect=1) print(gph) if(device!="")dev.off() } `g2.3` <- function(dset = possum, x = totlngth, here = possum$sex == "f", device="", ytex=0.8, cex.jm=0.9) { yglim <- c(0,1) if(device!="")hardcopy(device=device, width=4.25, height=2) else yglim <- c(0.265,0.735) dname <- as.character(substitute(dset)) xnam <- as.character(substitute(x)) x <- dset[here, xnam] n <- length(x) if(dname == "possum") { xlab <- switch(xnam, totlngth = "Total length (cm)", pes = "Length of foot (cm)") } else xlab <- xnam oldpar <- par(mar = c(4.1, 0.6, 0.6, 0.6)) on.exit(par(oldpar)) z <- boxplot(list(val = x), plot = F) xlim <- range(c(z$stats, z$out)) xlim <- xlim + c(-0.025,0.05) * diff(xlim) ylim <- c(.55,1.5) par(fig=c(0, 0.665, yglim[1], yglim[2])) plot.new() plot.window(xlim, ylim) top <- 0.7 bxp(z, at=top, boxwex = 0.15, xlab = "", xlim=xlim, ylim=ylim, horiz=TRUE, add=TRUE) chh <- par()$cxy[2] chw <- par()$cxy[1] text(z$stats[5], top+0.35*chh, "Largest value \n(there are no outliers)", adj = 0, cex = cex.jm, srt=90) text(z$stats[4], top+0.65*chh, "upper quartile", adj = 0, srt=90, cex = cex.jm) text(z$stats[3], top+0.65*chh, "median", adj = 0, srt=90, cex = cex.jm) text(z$stats[2], top+0.65*chh, "lower quartile", adj = 0, srt=90, cex = cex.jm) text(z$stats[1], top+0.35*chh, "Smallest value \n(outliers excepted)", adj = 0, srt=90, cex = cex.jm) if(!is.null(z$out)) text(z$out[1], top+0.35*chh, "Outlier", adj = 0, srt=90, cex = cex.jm) # lines(c(90, 90), z$stats[c(2, 4)]) av <- mean(z$stats[c(2, 4)]) q1 <- z$stats[2] q3 <- z$stats[4] axis(1, at = c(q1, q3), tck = 0.02, labels = F) botm<-par()$usr[3] text(c(q1, q3), rep(top-chh,2), c(format(round(q1, 2)), format(round(q3, 1))),adj=0.5, cex=cex.jm) qtop <- q3 + 0.5 * chh mtext(side=1,line=2.5,xlab) par(fig=c(0.675, 1, yglim[1], yglim[2]), new=T) plot(0:1, 0:1, bty="n", axes=F, xlab="", ylab="", type="n") text(0, ytex, "Inter-quartile range", adj = 0, cex = cex.jm) text(0.15, ytex - 1.15 * chh, paste("= ", format(round(q3, 2)), "-", format(round(q1, 2)), "\n= ", format(round(q3 - q1, 2))), adj = 0, cex = cex.jm) here <- !is.na(x) sd <- sqrt(var(x[here])) text(0, ytex - 5 * chh, paste("Compare\n", "0.75 x Inter-quartile range", "\n =", format(round(0.75 * (q3 - q1), 1)), "\nwith", "standard deviation\n =", format(round(sd, 1))), adj = 0, cex = cex.jm) n <- sum(here) if(device!="")dev.off() par(fig=c(0,1,0,1)) par(oldpar) invisible() } `g2.4` <- function(device="") { if(device!="")hardcopy(device=device, width=4.8, height=3.8) oldpar <- par(mar=c(3.6,5.1,2.1,1.1), oma=c(0.5,0,0,0), mgp=c(3.5,0.75,0)) on.exit(par(oldpar)) par(fig=c(0, 1, .4, 1)) plot(log(measles,10), xlab="", ylim=c(0,log(5000*1000, 10)), ylab=" Deaths; Population (log scale)", yaxt="n") ytikpoints <- c(1, 10, 100,1000, 1000000, 5000000) axis(2, at=log10(ytikpoints), labels=paste(ytikpoints), cex=.75, las=2) londonpop <- ts(c(1088,1258,1504,1778,2073,2491,2921,3336,3881,4266, 4563,4541,4498,4408), start=1801, end=1931, deltat=10) points(log(londonpop*1000,10), pch=16, cex=.5) mtext(side=3, line=0.5, "A (1629-1939)", adj=0) par(fig=c(0, 1, 0, .45), mar=c(2.1,5.1,3.1,1.1), new=TRUE) plot(window(measles, start=1840, end=1882), xlab="Year", yaxt="n", ylim=c(0,4600), ylab="Deaths; Population in 1000s") points(londonpop, pch=16, cex=.5) axis(2, at=(1:4)*1000, cex=.75, las=2) mtext(side=3, line=0.5, "B (1841-1881)", adj=0) if(device!="")dev.off() invisible() } `g2.4a` <- function(width=3.25, height=3.25, pointsize=c(8,4), device=""){ if(device!="") hardcopy(width=width, height=height, color=F, pointsize=pointsize, trellis=TRUE, device=device) lset(list(superpose.symbol= list(col=c("gray","black"), pch=c(16,16)), superpose.line= list(col=c("gray","black"), lty=1:2))) ## Specify after opening any new graphics device here <- ais$sport %in% c("Field","Swim","T_400m","T_Sprnt") gph <- xyplot(ht ~ wt | sport, groups=sex, subset=here, data=ais, auto.key=list(columns=2), type=c("p","smooth"), span=1.0) print(gph) ## The parameter "span" controls the extent of smoothing. if(device!="")dev.off() } `g2.5` <- function(device=""){ if(device!="")hardcopy(device=device, width=2, height=2) oldpar <- par(mar = c(4.1,4.1,1.1,1.1), mgp=c(2.5,0.75,0), pty="s") on.exit(par(oldpar)) xyrange <- range(milk) plot(four ~ one, data = milk, xlim = xyrange, ylim = xyrange, pch = 16, cex=.6) rug(milk$one, ticksize=0.04) rug(milk$four, side = 2, ticksize=0.04) abline(0, 1) if(device!="")dev.off() } `g2.6` <- function(df=fruitohms, device=""){ if(device!="")hardcopy(width=4, height=2, device=device) oldpar<-par(mar=c(4.1,3.6, 1.6, 0.6), mgp=c(2.5, 0.75,0), pty="s", oma=c(0,1.1,0,1.1) ) on.exit(par(oldpar)) par(mgp=c(2.75,1,0)) par(mfrow=c(1,2)) plot(ohms~juice, data=df, cex=0.8, xlab="Apparent juice content (%)", ylab="Resistance (kOhm)", yaxt="n") mtext(side=3, line=0.25, "A", adj=0) axis(2, at=(1:5)*2000, labels=paste((1:5)*2)) plot(ohms~juice,data=df,cex=0.8,xlab="Apparent juice content (%)", ylab="",yaxt="n") mtext(side=3, line=0.25, "B", adj=0) axis(2, at=(1:5)*2000, labels=paste((1:5)*2)) lines(lowess(fruitohms$juice,fruitohms$ohms), lwd=2, col="gray40") if(device!="")dev.off() } `g2.7` <- function(dset = Animals, show = "lines", device="", color = F) { library(MASS) data(Animals) if(device!="")hardcopy(width=4, height=2, device=device) oldpar <- par(mfcol = c(1, 2), mar = c(3.1,3.1,2.1,3.1), oma=c(0,1.1,0,1.1), mgp = c(2.25, 0.65, 0), pty="s") on.exit(par(oldpar)) fig1txt <- paste("(a) Untransformed scale") fig2txt <- paste("(b) Logarithmic scale, both axes") xlab <- "Body weight (kg x 100)" ylab <- "Brain weight (g)" dset$body <- dset$body/100 plot(dset$body, dset$brain, xlab = xlab, ylab = ylab, type = "n") points(dset$body, dset$brain) mtext(side=3, line=1, "A", adj=-0.1) eqscplot(log10(dset$body), log10(dset$brain), pch = 1, axes = F, xlab = xlab, ylab = ylab) mtext(side=3, line=1, "B", adj=-0.1) xpos <- sort(unique(round(log10(dset$body)))) ypos <- sort(unique(round(log10(c(0.1,dset$brain))))) lab <- paste(10^xpos) par(cex=0.85) axis(1, at = xpos, label = lab,cex=.75) axis(3, at = xpos) axis(4, at = ypos) par(mgp = c(2.5, 0.75, 0)) axis(2, at = ypos, label = paste(10^ypos, sep = ""), srt = 90) mtext(side = 3, line = 2, "log10(Body weight)") mtext(side = 4, line = 2, "log10(Brain weight)") box() if(device!="")dev.off() } `g2.8` <- function(dset = cuckoos, device="") { if(device!="")hardcopy(width=3.75, height=3.75, device=device, trellis=TRUE, pointsize=c(10, 7)) ## Two lattice graphs on one page: data frame cuckoos (DAAG) library(lattice) library(grid) trellis.par.set(layout.heights=list(key.top=0.5, axis.top=0.6, bottom.padding=0.25)) attach(cuckoos) nam <- levels(cuckoos$species) splitnam <- strsplit(nam,"\\.") newnam <- sapply(splitnam, function(x)if(length(x)==1)x else paste(x,collapse=" ")) cuckoos.strip <- stripplot(species ~ length, xlab="", data=cuckoos, legend=list(top=list(fun=textGrob, args=list(label="A", x=0, just="left")))) print(cuckoos.strip, position=c(0,.5,1,1)) cuckoos.bw <- bwplot(species~length, xlab="Length of egg (mm)", data=cuckoos, legend=list(top=list(fun=textGrob, args=list(label="B", x=0, just="left")))) print(cuckoos.bw, newpage=FALSE, position=c(0,0,1,.5)) detach(cuckoos) if(device!="")dev.off() invisible() } `g2.9` <- function(device=""){ if(device!="")hardcopy(width=5, height=4.5, color=FALSE, device=device, trellis=TRUE, pointsize=8) Jobs <- stack(jobs, select = 1:6) # Column 1 first, then 2, ... # The stack() function was discussed in Chapter 1 Jobs$Year <- rep(jobs[, 7], 6) names(Jobs) <- c("Number", "Province", "Year") plot.new() oldpar <- par(mar=c(2.6,3.6,2.6,1.6), fig=c(0,1,0.6,1), mgp=c(2.0,0.5,0)) if(device!="")par(cex=0.65) on.exit(par(oldpar)) mtext(side=3, line=1, "A", adj=0, cex=0.75) par(fig=c(0,1,0,0.58), mar=c(2.6,3.6,2.6,1.6), mgp=c(2.0,0.5,0), new=TRUE) mtext(side=3, line=1, "B", adj=0, cex=0.75) library(DAAG) jobts <- ts(jobs[,1:6], start=1995, frequency=12) ylim <- range(jobts) ylim <- ylim+diff(ylim)*c(-0.02,0.05) par(fig=c(0.21,0.79,0.58,1),new=TRUE, mar=c(2.6,3.6,2.6,1.6), mgp=c(2.0,0.5,0)) plot(jobts, plot.type="single", xlim=c(1995,1997.4), lty=1:5, log="y", xaxt="n", xlab="", ylab="Number of Jobs", ylim=ylim, bty="l") ylast <- bounce(window(jobts, 1996+11/12), d=1.25*strheight("O"), log=TRUE) text(rep(1996+11/12,6), ylast, colnames(ylast), pos=4, xpd=T, cex=0.85) datlab <- format(seq(from=as.Date("1Jan1995", format="%d%b%Y"), by="3 month", length=8), "%b%Y") axis(1, at=seq(from=1995, by=0.25, length=8), datlab) par(oldpar) par(mar=rep(0,4), tcl=-0.25, mgp=c(1.5,0.5,0), cex.axis=0.6) par(fig=c(0.775,1,0,.55), new=TRUE) nums <- Jobs$Number lognums <- log(nums) ylim <- range(lognums) ylim <- ylim+diff(ylim)*c(-0.05,0.05) # plot.new() plot.window(c(0,1),ylim=ylim) popval <- (1:5)*1000 logval <- log(popval) chw <- par()$cxy[1] chh <- par()$cxy[2] xmid <- 0.575 axis(2, at=logval, pos=xmid-0.01, labels=round(log(popval),2), las=2) axis(4, at=logval, pos=xmid+0.01, labels=popval, las=2) par(xpd=TRUE) text(xmid+0.5*chw, logval[5]+0.75*chh, "Number", adj=0, cex=0.6) text(xmid-0.5*chw, logval[5]+0.75*chh, "log(Number)", adj=1, cex=0.6) Jobs <- stack(jobs, select = 1:6) Jobs$Year <- rep(jobs[, 7], 6) names(Jobs) <- c("Number", "Province", "Year") xy <- xyplot(log(Number) ~ Year|Province, data = Jobs, scales = list(y = list(relation = "sliced", tick.number=4, cex=0.75)), type = "l", layout=c(3,2), cex=0.45, par.strip.text = list(cex = 0.7)) print(xy, position=c(0,0,0.775,0.55), newpage=FALSE) if(device!="")dev.off() } `gdump` <- function(fnam=NULL, prefix="~/r-book/ed2/figures/figs", splitchar="/ch"){ if(is.null(fnam)){ path <- getwd() pathtag <- strsplit(path, "/ch", fixed=TRUE)[[1]] fnam <- paste(prefix, pathtag[length(pathtag)], ".R", sep="") } else fnam <- paste(prefix, fnam, sep="/") objnames <- c(objects(pattern="^g", envir=sys.frame(0)), "hardcopy") cat("\nDump to file:", fnam, "\n") print(objnames) dump(objnames, fnam) } `gfile` <- function(width=3.75, height=3.75, color=F, trellis=F, device=c("","pdf","ps"), path="", pointsize=c(8,5), horiz=F){ ## 1 x 1: 2.25" x 2.25" ## 2 x 2: 2.75" x 2.75" ## 3 x 3: 3.75" x 3.75" or 3.25" x 3.25" for simple scatterplots ## 1 x 2: 4" x 2.25" ## 2 x 3: 4" x 2.8" ## 3 x 4: 4.5" x 3.25 if(!trellis)pointsize <- pointsize[1] funtxt <- sys.call(1) fnam <- strsplit(as.character(funtxt), "(", fixed=T)[[1]][1] dotsplit <- strsplit(fnam, "\\.")[[1]] dotsplit[1] <- substring(dotsplit[1], 2) prefix1 <- paste(if(nchar(dotsplit[1])==1)"0" else "", dotsplit[1], sep="") prefix2 <- paste(if(nchar(dotsplit[2])==1)"0" else "", dotsplit[2], sep="") if(device=="")stop("No device has been specified") suffix <- switch(device, ps=".eps", pdf=".pdf") fnam <- paste("~/r-book/second/Art/",prefix1,"-",prefix2, suffix, sep="") print(fnam) dev.out <- device[1] dev.fun <- switch(dev.out, pdf=pdf, ps=postscript) if(trellis){ library(lattice) trellis.device(file=fnam, device=dev.fun, color = color, width=width, height=height, horiz=horiz) trellis.par.set(fontsize=list(text=pointsize[1], points=pointsize[2])) } else if (dev.out!=""){ print(c(width, height)) dev.fun(file=fnam, paper="special", enc="MacRoman", horiz=horiz, width=width, height=height, pointsize=pointsize[1]) } } `gfocus.demo` <- function(device=""){ library(lattice) library(grid) if(device!="")hardcopy(device=device, width=4, height=2.25, trellis=TRUE, color=TRUE) trellis.par.set(layout.heights=list(key.top=0.25, axis.top=0.5)) hp1.plt1 <- xyplot(o2 ~ wattsPerKg, groups=id, data=humanpower1, panel=function(x,y,subscripts,groups,...){ u <- lm(y~groups*x); hat <- fitted(u) panel.superpose(x,y,subscripts,groups) panel.superpose(x,hat,subscripts,groups, type="l") }, ## key=simpleKey(text=rep("",5), lines=TRUE, columns=5), xlab="Watts per kilogram", ylab=expression("Oxygen intake ("*ml.min^{-1}*.kg^{-1}*")"), legend=list(top=list(fun=textGrob, args=list(label="A", x=0)))) print(hp1.plt1, position=c(0,0,.535,1)) u <- lme(o2 ~ wattsPerKg, random=~wattsPerKg|id, data=humanpower1) hp1.plt2 <- xyplot(o2 ~ wattsPerKg, groups=id, data=humanpower1, panel=function(x,y,subscripts,groups,...){ u <- lm(y~groups*x); hat <- fitted(u) panel.superpose(x,hat,subscripts,groups, type="l") }, xlab="Watts per kilogram", ylab="", legend=list(top=list(fun=textGrob, args=list(label="B", x=0)))) hat <- fitted(u) print(hp1.plt2, position=c(.465, 0,1,1), newpage=FALSE) trellis.focus("panel", row=1, column=1) arglist <- trellis.panelArgs() panel.superpose(x=arglist$x,y=hat,subscripts=arglist$subscripts, groups=arglist$groups, , type="l", lty=2) trellis.unfocus() if(device!="")dev.off() } `gsave` <- function(fnam=NULL, prefix="~/r-book/ed2/figures/figs", splitchar="/ch", xtras=c("renum.fun","renum.files","hardcopy")){ if(is.null(fnam)){ path <- getwd() pathtag <- strsplit(path, "/ch", fixed=TRUE)[[1]] fnam <- paste(prefix, pathtag[length(pathtag)], ".RData", sep="") } else fnam <- paste(prefix, fnam, sep="/") objnames <- c(objects(pattern="^g", envir=sys.frame(0)), xtras) cat("\nDump to file:", fnam, "\n") print(objnames) save(list=objnames, file=fnam) } `gtest` <- function(){ trellis.device(postscript, file="test.eps") trellis.par.set(layout.heights=list(key.top=0.5)) zz.d <- dotplot(variety ~ yield, data = barley, legend=list(top=list(fun=grid.text, args=list(label="ABC", x=0)))) pushViewport(viewport(layout=grid.layout(2, 1))) pushViewport(viewport(layout.pos.row=1)) print(zz.d,newpage=FALSE) upViewport() pushViewport(viewport(layout.pos.row=2)) print(zz.d, newpage=FALSE) popViewport(2) dev.off() } `hardcopy` <- function(width=3.75, height=3.75, color=FALSE, trellis=FALSE, device=c("","pdf","ps"), path=getwd(), file=NULL, format=c("nn-nn", "name"), split="\\.", pointsize=c(8,4), fonts=NULL, horiz=FALSE, ...){ if(!trellis)pointsize <- pointsize[1] funtxt <- sys.call(1) nam <- strsplit(as.character(funtxt), "(", fixed=TRUE)[[1]][1] suffix <- switch(device, ps=".eps", pdf=".pdf") if(is.character(path) & nchar(path)>1 & substring(path, nchar(path))!="/") path <- paste(path, "/", sep="") if(is.null(file)) if(format[1]=="nn-nn"){ if(!is.null(split))dotsplit <- strsplit(nam, split)[[1]] else dotsplit <- nam if(length(dotsplit)==1)dotsplit <- c("", dotsplit) nn2 <- paste(if(nchar(dotsplit[2])==1)"0" else "", dotsplit[2], sep="") if(nchar(dotsplit[1])>0){ numstart <- which(unlist(strsplit(dotsplit[1], "")) %in% paste(0:9))[1] nn1 <- substring(dotsplit[1], numstart) nn1 <- paste(if(nchar(nn1) == 1) "0" else "", nn1, "-", sep="") } else nn1 <- "" file <- paste(nn1, nn2, sep="") } else file <- nam if(nchar(file)>4 & substring(file, nchar(file)-nchar(suffix)+1)==suffix) suffix <- "" file <- paste(path, file, suffix, sep="") print(paste("Output will be directed to file:", file)) dev.out <- device[1] dev.fun <- switch(dev.out, pdf=pdf, ps=postscript) if(trellis){ library(lattice) if(device=="ps") trellis.device(file=file, device=dev.fun, color = color, horiz=horiz, fonts=fonts, width=width, height=height, ...) else trellis.device(file=file, device=dev.fun, fonts=fonts, color = color, width=width, height=height, ...) trellis.par.set(list(fontsize=list(text=pointsize[1], points=pointsize[2]))) } else if (dev.out!=""){ print(c(width, height)) if(device=="ps") dev.fun(file=file, paper="special", horiz=horiz, fonts=fonts, width=width, height=height, pointsize=pointsize[1], ...) else dev.fun(file=file, paper="special", fonts=fonts, width=width, height=height, pointsize=pointsize[1], ...) } if(trellis)trellis.par.set(list(fontsize=list(text=pointsize[1], points=pointsize[2]))) }