gcol1 <-
function(device=""){
if(device!="")hardcopy(device=device, pointsize=10,
width=6, height=7.25, family="Times",
fonts=c("Courier","Times"))
oldpar <- par(mar = c(0,0,2.75,0), oma=c(0,0.5,0,0.5), xaxs="i",
xaxt="n", yaxt="n", ann=FALSE, cex.main=1.15)
on.exit(par(oldpar))
##
code10 <- "par(fig=c(0, 1, 0.425, 1))"
code11 <- "A: Plot symbols and text; specify colors and/or character expansion"
code1 <- c('plot(0, 0, xlim=c(0, 13.25), ylim=c(0, 19), type="n");',
"xpos <- rep((0:12)+0.5, 2); ypos <- rep(c(14.5,12.75), c(13,13));",
"points(xpos, ypos, cex=2.5, col=1:26, pch=0:25);",
"text(xpos, ypos, labels=paste(0:25), cex=0.75);")
makefig <- function(tx10=code10, tx11=code11, tx1=code1){
comm <- regexpr("#", code1, fixed=TRUE)==1
eval(parse(text=paste(c(tx10, ";", tx1[!comm]), collapse=" ")))
box(col="gray")
par(family="Courier")
mtext(side=3, line=0.3, tx10, adj=0.015)
par(family="Times")
title(main=tx11, adj=0, line=1.5, cex=1.25)
par(family="Courier")
ht <- par()$cxy[2]*1.025
y0 <- par()$usr[4]
for(i in 1:length(tx1))text(0.15, y0-(i-0.25)*ht,
substring(tx1[i], 1, nchar(tx1[i])-1), adj=0)
}
makefig()
code21 <- "## Plot characters, vary cex (expansion)"
ht <- par()$cxy[2]*1.025
text(0.15, 11.5*ht, code21, adj=0)
code22 <- 'text((0:4)+0.5, rep(9*ht, 5), letters[1:5], cex=c(2.5,2,1,1.5,2))'
text(0.15, 10.5*ht, code22, adj=0)
eval(parse(text=code22))
code23 <- "## Position label with respect to point"
text(0.15, 6.9*ht, code23, adj=0)
code24 <- c('xoff <- c(0, -0.5, 0, 0.5)',
'yoff <- c(-1,0,1,0)',
'col4 <- colors()[c(52, 116, 547, 610)]',
'points(10.6+xoff, 6+yoff, pch=16, cex=1.5, col=col4)',
'posText <- c("below (pos=1)", "left (2)", "above (3)", "right (4)")',
'text(10.6+xoff, 6+yoff, posText, pos=1:4)',
'rect(8.2, 3.8, 13.1, 8.2, border="red")')
eval(parse(text=code22))
eval(parse(text=paste(code24, collapse="; ")))
len <- length(code24)
for(i in 1:len)text(0.15,(len-0.1-i)*ht, code24[i], adj=0)
code10 <- "par(fig=c(0, 1, 0.01, 0.41), new=TRUE)"
code11 <- 'B: Rectangles, polygons, circles, and mathematical text'
code1 <- c('plot(0, 0, xlim=c(0, 13.25), ylim=c(0, 12), type="n");',
'xleft <- 10.4; xright <- 13.15;',
'ylo <- 0; yhi <- 12;',
'rect(xleft, ylo, xright, yhi, border="red");',
'polygon(x=c(10.5,13,12), y=c(7,8,11.5), col="gray");',
' ',
'## Draw a circle, overlay 2-headed arrow (code=3) ',
'symbols(11.8, 3.5, circles=1.2, bg="gray", add=TRUE, ',
' inches=FALSE);',
'arrows(11.8, 3.5, 10.6, 3.5, length=.05, code=3);',
' ',
'## Use expressions to add labeling information ',
'text(11.2, 3.5-strheight("R"), expression(italic(r)));',
'text(11.8, 5, expression("Area" == pi*italic(r)^2));')
makefig()
if(device!="")dev.off()
}
gcol2 <-
function(device="", pointsize=c(8,4)){
if(!require(DAAG))return("Package 'DAAG' is not installed -- cannot proceed")
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, aspect=0.8,
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, aspect=0.8,
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()
}
gcol3 <-
function(device="", path="~/dbeta/Art/")
{
if(!require(limma))return("Package 'limma' is not installed -- cannot proceed")
if(!require(DAAGbio))return("Package 'DAAGbio' is not installed -- cannot proceed")
MA <- normalizeWithinArrays(coralRG, method = "printtiploess")
nMA <- normalizeBetweenArrays(MA)
if(device!="")hardcopy(width=5.8, height=7.6, path=path,
device=device, pointsize=c(9,5))
xplot(data=sweep(nMA$M,2,c(-1,1,-1,1,-1,1),"*"),
images=1:6, mfrow=c(3,2),
paneltitles = c("1", "1A (dyeswap of 1)", "2",
"2A (dyeswap of 2)", "3", "3A (dyeswap of 3)"),
FUN=function(z,layout)imageplot(z,layout,legend=F, xlab="",
mar=c(.3,.6,1.4,.50)))
if(device!="")dev.off()
invisible()
}
gcol4 <-
function(device="", las=1, zlim=c(0, 1), nlevels = 9,
levels = pretty(zlim, nlevels), color.palette = rgb.palette,
colpal=rev(rgb.palette(10)), path="~/dbeta/Art/")
{
if(!require(dichromat))return("Package 'dichromat' is not installed -- cannot proceed")
rgb.palette<-colorRampPalette(c("red","orange","blue"), space="rgb")
fac <- c(0, 0.33, 0.66, 1)
if(device!="")hardcopy(width=4.5, height=2.4, device=device, path=path)
if(!exists("frogs.glm"))frogs.glm <-
glm(formula = pres.abs ~ log(distance) + log(NoOfPools) + meanmin +
meanmax, family = binomial, data = frogs)
nlevels <- length(levels)
mar.orig <- (par.orig <- par(c("mar", "las", "mfrow")))$mar
on.exit(par(par.orig))
w <- (mar.orig[2]) * par("csi") * 2.54
layout(matrix(c(2, 1), nc = 2), widths = c(1, lcm(w)))
par(las = las, mgp=c(2.75, .75, 0))
mar <- c(4.6, 0.5, 1.6, 1)
par(mar = mar)
plot.new()
plot.window(xlim = c(0, 1), ylim = range(levels), xaxs = "i",
yaxs = "i")
rect(0, levels[-length(levels)], 1, levels[-1], col = colpal)
color.lab <- paste(levels[-nlevels], "-", levels[-1], sep="")
text(0.5, 0.5*(levels[-1]+levels[-nlevels]), color.lab, cex=0.75)
mar[2] <- 4.1
mar[4] <- 0.5
par(mar=mar)
hat <- fitted(frogs.glm)
plot(northing~easting, data=frogs, type="n", asp=1,
xlab="Meters east of reference point",ylab="Meters north")
points(northing~easting, data=frogs, pch=15,
col=colpal[trunc(hat*nlevels)+1], cex=1.25)
points(northing~easting, data=frogs, pch=c(1,3)[frogs$pres.abs+1],
cex=0.65)
if(device!="")dev.off()
invisible()
}
gcol5 <-
function(device=""){
if(!require(lattice))return("Package 'lattice' is not installed -- cannot proceed")
if(device!="") hardcopy(width=4.25, height=4.25,
device=device, trellis=T, color=T)
if(!require(DAAG))return("Package 'DAAG' is not installed -- cannot proceed")
colr <- c("red","blue")
pchr <- c(3,4,0,8,2,10,1)
ss <- expand.grid(site=1:7, sex=1:2)
ss$sexsite <- paste(ss$sex, ss$site, sep="-")
sexsite <- paste(possum$sex, possum$site, sep="-")
print(splom(~ possum[, c(9:11)], panel = panel.superpose,
groups = sexsite, col = colr[ss$sex], pch = pchr[ss$site],
varnames=c("tail\nlength","foot\nlength",
"ear conch\nlength"),
key = list(points = list(pch=pchr),
text=list(c("Cambarville","Bellbird","Whian Whian ",
"Byrangery", "Conondale ","Allyn River","Bulburin")),
columns=4, cex=.75, between=1,
between.columns=2), cex=.65, main=""))
if(device!="")dev.off()
}
gcol6 <-
function(device=""){
if(!require(lattice))return("Package 'lattice' is not installed -- cannot proceed")
if(!require(DAAG))return("Package 'DAAG' is not installed -- cannot proceed")
if(device!="") hardcopy(width=4.5, height=9,
device=device, trellis=T, color=T)
pchr <- c(3,4,0,8,2,10,1)
cloudgph <- cloud(earconch~taill+footlgth, data=possum, groups=site,
par.settings=simpleTheme(pch=pchr, cex=0.7),
zoom=0.925, zlab=list("earconch", rot=90),
auto.key = list(text=c("Cambarville","Bellbird","Whian Whian ",
"Byrangery", "Conondale ","Allyn River","Bulburin"),
columns=4, between=1, points=TRUE,
between.columns=2))
plot(cloudgph)
if(device!="")dev.off()
}
gcol7 <-
function(colr=trellis.settings$superpose.symbol$col[c(2,5)],
device=""){
if(device!="")hardcopy(width=3.25, height=3.25,
device=device)
if(!require(lattice))return("Package 'lattice' is not installed -- cannot proceed")
here<-!is.na(possum$footlgth) # We need to exclude missing values
print(sum(!here)) # Check how many values are missing
possum.prc <- princomp(possum[here,6:14]) # Principal components
colr <- c("red", "blue")
pchr <- c(3,4,0,8,2,10,1)
ss <- expand.grid(site=1:7, sex=1:2)
ss$sexsite <- paste(ss$sex, ss$site, sep="-")
sexsite <- paste(possum$sex, possum$site, sep="-")[here]
print(xyplot(possum.prc$scores[,2] ~ possum.prc$scores[,1], aspect="iso",
panel = panel.superpose,
groups = sexsite, col = colr[ss$sex], pch = pchr[ss$site],
key = list(points = list(pch=pchr),
text=list(c("Cambarville","Bellbird","Whian Whian ",
"Byrangery", "Conondale ","Allyn River","Bulburin")),
columns=4, cex=.5, between=1, between.columns=2),
cex=0.65, xlab="1st Principal Component",
ylab="2nd Principal Component"
))
if(device!="")dev.off()
}
gcol8 <-
function(device=""){
if(device!="") hardcopy(width=6.25, height=3.5, trellis=F,
color=TRUE, pointsize=8, device=device)
oldpar <- par(mar = c(4.1, 3.6, 2.6, 0.1), mgp = c(2.25, 0.5,
0), mfrow = c(1, 2), oma = c(0, 0.6, 0, 1.1), pty="s")
on.exit(par(oldpar))
if(!require(hddplot))return("Package 'hddplot' is not installed -- cannot proceed")
attach(golubInfo)
## Identify allB samples for that are BM:f or BM:m or PB:m
subsetB <- cancer=="allB" & tissue.mf%in%c("BM:f","BM:m","PB:m")
## Form vector that identifies these as BM:f or BM:m or PB:m
tissue.mfB <- tissue.mf[subsetB, drop=TRUE]
## Separate off the relevant columns of the matrix Golub
data(Golub)
GolubB <- Golub[, subsetB]
tissue.mfB.cv <- cvdisc(GolubB, cl=tissue.mfB, nfeatures=1:23)
tissue.mfB.scores <-
cvscores(cvlist = tissue.mfB.cv,
nfeatures = 3, ndisc = NULL, cl.other = NULL)
scoreplot(scorelist = tissue.mfB.scores, cl.circle=NULL,
prefix="A: B-cell subset -", xlab="Discriminant function 1",
ylab="Discriminant function 2",
adj.title=0)
Golub.BM <- with(golubInfo, Golub[, BM.PB=="BM"])
cancer.BM <- with(golubInfo, cancer[BM.PB=="BM"])
BMonly.cv <- cvdisc(Golub.BM, cl=cancer.BM, nfeatures=1:23,
nfold=c(10,4))
BMonly.scores <-
cvscores(cvlist=BMonly.cv, nfeatures=11, cl.other=NULL)
scoreplot(scorelist=BMonly.scores, cl.circle=tissue.mfB,
circle=tissue.mfB%in%c("BM:f","BM:m"),
params=list(circle=list(cex=1.3, col=c("pink","cyan")),
points=list(cex=0.65)), xlab="Discriminant function 1",
ylab="",
prefix="B: BM samples -", adj.title=0)
detach(golubInfo)
if(device!="")dev.off()
}
gcol9 <-
function(device=""){
load('cps3.RData')
if(device!="")hardcopy(width=6, height=4.5, trellis=TRUE, color=TRUE,
device=device, pointsize=c(6,3))
if(!require(grid))return("Package 'grid' is not installed -- cannot proceed")
dsetnames <- c("nsw-ctl", "nsw-trt", "psid1", "psid2", "psid3",
"cps1", "cps2", "cps3")
colrs <- c("gray","black", trellis.par.get()$superpose.line$col[1:3])
lty <- c(1,2,1,1,1)
lwd <- c(1.5,1,1,1,1)
denplot <-
function(sel=c(1:2,6:8), yvar="re75", offset=30, ylim=c(0,1.75),
from=NULL, at=c(.5,1,1.5), labels=paste(at), bw="nrd0",
ylab="Density", takelog=TRUE, col.axis="black"){
nzre <- unlist(lapply(list(subset(nswdemo, trt==0),
subset(nswdemo, trt==1),
psid1, psid2, psid3, cps1, cps2, cps3)[sel],
function(x){z <- x[,yvar]; z[z>0]}))
num <- unlist(lapply(list(subset(nswdemo, trt==0), subset(nswdemo, trt==1),
psid1, psid2, psid3, cps1, cps2, cps3),
function(x){z <- x[,yvar]; sum(z>0)}))
xy <- data.frame(nzre=nzre,
fac = factor(rep(dsetnames[sel], num[sel]),
levels=dsetnames[sel]))
if(takelog) {
y <- log(xy$nzre+offset)
xlab <- paste("log(", yvar, "+", offset, ")", sep="")} else
{
y <- xy$nzre
xlab <- yvar
}
densityplot(~ y, groups=fac, data=xy, bw=bw, from=from,
scales=list(y=list(at=at, labels=labels, col=col.axis),
tck=0.25),
plot.points=FALSE,
col=colrs[1:5], lwd=lwd, lty=lty,
key=list(x=0.01, y=0.99, text=list(dsetnames[sel[3:5]]),
col=colrs[3:5],
lines=list(lwd=rep(1.5,3)), between=1),
par.settings=simpleTheme(col=colrs, lty=lty,
lwd=lwd), ylim=ylim, ylab=ylab,
xlab=xlab)
}
print(denplot(), position=c(0, 0, 0.32, 0.505))
print(denplot(1:5, ylab=" ", col.axis="white"),
position=c(0.21, 0, .53, 0.505), newpage=FALSE)
print(denplot(ylab=" ", yvar="re78", col.axis="white"),
position=c(0.47, 0, 0.79, 0.505),
newpage=FALSE)
print(denplot(1:5, ylab=" ", yvar="re78", col.axis="white"),
position=c(0.68, 0, 1, 0.505), newpage=FALSE)
## Age
print(denplot(yvar="age", takelog=FALSE, ylim=c(0,0.1), from=16,
at=c(.02,.04,.06,.08), labels=c(".02",".04",".06",".08")),
position=c(0, 0.48, 0.32, .985), newpage=FALSE)
print(denplot(1:5, yvar="age", takelog=FALSE, ylim=c(0,0.1), from=16,
at=c(.02,.04,.06,.08), labels=c(".02",".04",".06",".08"),
ylab=" ", col.axis="white"),
position=c(0.21, 0.48, .53, .985), newpage=FALSE)
## educ
print(denplot(1:5, yvar="educ", takelog=FALSE, ylim=c(0,0.5), bw=0.5,
at=c(.1,.2,.3,.4), ylab=" "),
position=c(0.47, 0.48, .79, .985), newpage=FALSE)
print(denplot(yvar="educ", takelog=FALSE, ylim=c(0,0.75), bw=0.5,
at=c(.1,.2,.3,.4), ylab=" ", col.axis="white"),
position=c(0.68, 0.48, 1, .985), newpage=FALSE)
## Now use grid functions to add text to the graphics page
pushViewport(viewport(y=unit(1,"npc"), gp=gpar(cex=0.5),
width=0.5, height=unit(1.5,"lines"),
just=c("centre","top")))
draw.key(key=list(text=list(dsetnames[1:2]), lines=list(lty=lty[1:2],
lwd=lwd[1:2], col=colrs[1:2]), columns=2, between=1),
draw=TRUE)
popViewport(0)
if(device!="")dev.off()
}
gcol10 <-
function(nsw=rbind(psid1, subset(nswdemo, trt==1)), offset=30,
device="", path="~/dbeta/Art/"){
if(device!="")hardcopy(width=5.25, height=5.25, trellis=TRUE, path=path,
device=device, pointsize=c(8,5), color=TRUE)
vnames <- c("trt","educ","age","re75","re78")
nsw <- rbind(psid1, subset(nswdemo, trt==1))
## Check minimum non-zero values of re75 and re78
round(sapply(nsw[,c("re75","re78")], function(x)unique(sort(x))[2]))
nsw[,c("re75","re78")] <- log(nsw[,c("re75","re78")] + offset)
lab <- c(vnames[2:3], paste("log\n", vnames[-(1:3)], "+", offset))
nsw$trt <- factor(nsw$trt, labels=c("Control (psid1)","Treatment"))
trellis.par.set(superpose.symbol=list(cex=0.25, alpha=0.5),
superpose.line=list(lwd=2, alpha=0.5))
print(splom(~ nsw[,vnames[-1]], type=c("p","smooth"),
groups=nsw$trt, varnames=lab,
auto.key=list(columns=2, lines=TRUE)))
# print(table(trt[here]))
if(device!="")dev.off()
}
gcol11 <-
function(device="")
{
if(!require(splines))return("Package 'splines' is not installed -- cannot proceed")
if(!require(lattice))return("Package 'lattice' is not installed -- cannot proceed")
if(!require(MASS))return("Package 'MASS' is not installed -- cannot proceed")
if(device!="")hardcopy(width=5.25, height=5.25, device=device,
color=TRUE, trellis=TRUE, pointsize=c(8,4))
if(!require(randomForest))return("Package 'randomForest' is not installed -- cannot proceed")
trellis.par.set(fontsize=list(text=8,points=4))
col.line <- trellis.par.get()$superpose.line$col[1:2]
col.point <- trellis.par.get()$superpose.symbol$col[1:2]
nsw <- rbind(psid1, subset(nswdemo, trt==1))
nsw$trt <- factor(nsw$trt, labels=c("Control (psid1)",
"Treated (experimental)"))
nsw$fac74 <- factor(nsw$re74>0, exclude=NULL)
levels(nsw$fac74) <- c("0","gt0","<NA>")
set.seed(41)
nsw.rf <- randomForest(as.factor(trt) ~ ., data=nsw[, -c(7:8,10)],
sampsize=c(297,297))
logit <- function(p, offset=0.001)log((p+offset)/(1+offset-p))
trt <- nsw$trt
lprob.rf <- logit(predict(nsw.rf, type="prob")[,2])
nsw.lda <- lda(trt ~ ns(age,2) + ns(educ,2) + black + hisp + fac74 +
ns(log(re75+100),3), prior=c(.5, .5), data=nsw)
lprob.lda <- logit(predict(nsw.lda)$posterior[,2])
print(table(nsw$trt[lprob.lda > -4]))
nswa <- nsw[lprob.rf > -1.5, ]
nswb <- nsw[lprob.lda >- 4, ]
## Note that proximities are now requested.
nswa.rf <- randomForest(trt ~ ., data=nswa[, -c(7:8,10)])
lproba.rf <- logit(predict(nswa.rf, type="prob")[,2])
nswb.lda <- lda(trt ~ ns(age,2) + ns(educ,2) + black + hisp + fac74 +
ns(log(re75+100),3), prior=c(.5, .5), data=nswb)
lprobb.lda <- logit(predict(nswb.lda)$posterior[,2])
gph.key <- list(space="top", columns=2,
points=list(pch=c(1,3), cex=0.5, col=col.point),
lines=list(lwd=c(1.5,1.5), col=col.line),
text=list(c("psid1 controls", "experimental treatment")),
padding.text=1
)
gph0 <- xyplot(1 ~ 1, panel=function(x,y,...){}, xlab="", ylab="",
scales=list(draw=F),
key=gph.key,
par.settings=list(axis.line=list(col="transparent")))
gph1 <-
xyplot(age + educ + log(re75+100) ~ lproba.rf, groups=trt, layout=c(3,1),
data=nswa, type=c("p","smooth"), span=0.4, aspect=1,
par.settings=simpleTheme(lwd=c(1.5,1.5),
alpha.points=0.5,
pch=c(1,3), cex=0.4),
scales=list(y=list(relation="free"), tck=0.5),
xlab=" ", par.strip.text=list(cex=0.9),
main=textGrob("A: Random forest scores (filtered data)",
x=unit(0.075, "npc"),
y = unit(0, "npc"), just="left",
gp=gpar(cex=1))
)
gph2 <-
xyplot(age + educ + log(re75+100) ~ lprobb.lda, groups=trt, layout=c(3,1),
data=nswb, type=c("p","smooth"), span=0.4, aspect=1,
par.settings=simpleTheme(lwd=c(1.5,1.5),
pch=c(1,3), cex=0.4, alpha.points=0.5),
scales=list(y=list(relation="free"), tck=0.5),
xlab="Score", par.strip.text=list(cex=0.9),
main=textGrob("B: Linear discriminant analysis scores (filtered data)",
x=unit(.075, "npc"), y = unit(0, "npc"), just="left",
gp=gpar(cex=1)))
print(gph0, position=c(0,0.6,1,1))
print(gph1, position=c(0,0.475,1,0.95),newpage=FALSE)
print(gph2, position=c(0,0,1,0.525), newpage=FALSE)
if(device!="")dev.off()
invisible()
}
gcol12 <-
function(device="",new=F, ycol = 50-(0:23)*2.1-rep(c(0, 0.5), c(8,16)),
path="~/dbeta/Art/"){
if(device!="")hardcopy(width=5.8, height=6.8, device=device)
else if(new)x11(width=6.0, height=9)
yline <- 4.2
ypmax <- ycol[1]-1.25
farleft <- -7.0
oldpar <- par(mar=c(0,0,0.5,0))
on.exit(par(oldpar))
par(xpd=TRUE)
if(!require(RColorBrewer))return("Package 'RColorBrewer' is not installed -- cannot proceed")
plot(c(-7.5,31), c(0, ypmax), type="n", xlab="", ylab="", axes=F)
plot.palette <- function(y, colr, txt=NULL, x=farleft-0.5, x0=1.75){
if(is.null(txt)) txt <- deparse(substitute(colr))
num <- length(colr)
wid <- (31-x0)/num
oset <- (0:(num-1))*wid+x0
rect(oset,y-1.5,oset+wid,y, col=colr)
text(x, y-0.8, txt, adj=0)
}
plot.palette(y=ycol[1], colr=palette(), "Default palette")
## rect(oset8,ycol[1]-1.6,oset8+3.45,ycol[1], col=palette())
## text(farleft-0.5, ycol[1]-0.8, "Default palette", adj=0)
plot.palette(y=ycol[2], colr=heat.colors(12))
plot.palette(y=ycol[3], colr=terrain.colors(12))
plot.palette(y=ycol[4], colr=topo.colors(12))
plot.palette(y=ycol[5], colr=rainbow(12))
chh <- par()$cxy[2]
text(farleft-0.5, ycol[6]-1.5,
"Color schemes generated by hcl(h=seq(from=0, to=360, by=30), c, l)",
adj=0)
plot.palette(y=ycol[7]-0.25, colr=hcl(h=seq(from=0, to=360, by=30),
c=55,l=75), txt= "c = 55, l = 75",
x=farleft+2.25)
plot.palette(y=ycol[8]-0.25, colr=hcl(h=seq(from=0, to=360, by=30),
c=35,l=85), txt= "c = 35, l = 85",
x=farleft+2.25)
text(farleft-0.5, ycol[9]-1.75,
expression(italic("RColorBrewer")*
" package, "* 'e.g. brewer.pal(12, "Set3")'), adj=0)
text(farleft+0.5, ycol[10]-1.25, "Qualitative scales", adj=0)
plot.palette(y=ycol[11], colr=brewer.pal("Set3", n=12),
x=farleft+2.25, txt="Set3 (n=12)")
plot.palette(y=ycol[12], colr=brewer.pal("Paired", n=12),
txt="Paired (n=12)", x=farleft+2.25)
plot.palette(y=ycol[13], colr=brewer.pal("Spectral", n=11),
x=farleft+2.25, txt="Spectral (n=11)")
plot.palette(y=ycol[14], colr=brewer.pal("Set1", n=9),
x=farleft+2.25, txt="Set1 (n=9)")
plot.palette(y=ycol[15], colr=brewer.pal("Pastel1", n=9),
x=farleft+2.25, txt="Pastel1 (n=9)")
plot.palette(y=ycol[16], colr=brewer.pal("Pastel2", n=8),
x=farleft+2.25, txt="Pastel2 (n=8)")
plot.palette(y=ycol[17], colr=brewer.pal("Dark2",n=8),
txt="Dark2 (n=8)", x=farleft+2.25)
plot.palette(y=ycol[18], colr=brewer.pal("Accent",n=8),
txt="Accent (n=8)", x=farleft+2.25)
text(farleft+0.5, ycol[19]-1.25, "Divided scales (examples only)", adj=0)
plot.palette(y=ycol[20], colr=brewer.pal("RdGy", n=11),
x=farleft+2.25, txt="RdGy (n=11)")
plot.palette(y=ycol[21], colr=brewer.pal("BrBG", n=11),
x=farleft+2.25, txt="BrBG (n=11)")
text(farleft+0.5, ycol[22]-1.25, "Quantitative scales (examples only)",
adj=0)
plot.palette(y=ycol[23], colr=brewer.pal("PuBuGn", n=9),
x=farleft+2.25, txt="PuBuGn (n=9)")
plot.palette(y=ycol[24], colr=brewer.pal("OrRd", n=9),
x=farleft+2.25, txt="OrRd (n=9)")
if(device!="")dev.off()
}
gcol13 <-
function(device="", new=F, ycol = 47.5-(0:19)*2.1,
inc=c(3,5,10,12,13:14,18), path="~/dbeta/Art/"){
if(device!="")hardcopy(width=5.8, height=6.8, path=path,
device=device)
else if(new)x11(width=6.0, height=9)
eps <- numeric(length(ycol))
eps[inc] <- 0.35
ycol <- ycol-cumsum(eps)
yline <- 4.2
ypmax <- ycol[1]-1.75
ypmin <- min(ycol)-1.25
farleft <- -6
oldpar <- par(mar=c(0,0,0.5,0))
on.exit(par(oldpar))
par(xpd=TRUE)
if(!require(dichromat))return("Package 'dichromat' is not installed -- cannot proceed")
plot(c(-7,31), c(ypmin, ypmax), type="n", xlab="", ylab="", axes=F)
plot.palette <- function(y, colr, txt=NULL, x=farleft-0.5,
simulate=NULL, x0=3.5, dichrom=F, xtra=NULL){
if(is.null(txt)){
if(is.character(colr))txt <- colr else
txt <- deparse(substitute(colr))
}
if(dichrom)colr <- colorschemes[[colr]]
num <- length(colr)
wid <- (31-x0)/num
if(!is.null(xtra))wid <- (31-x0)/(num+1.25)
oset <- (0:(num-1))*wid+x0
if(!is.null(simulate)){
colr <- dichromat(colr, simulate)
addtxt <- switch(simulate, deutan="D", protan="P")
txt <- paste(txt,": ",addtxt, sep="")
if(!is.null(xtra)) xtra <- dichromat(xtra, simulate)
}
rect(oset,y-1.5,oset+wid,y, col=colr)
if(!is.null(xtra))rect(31-wid, y-1.5, 31, y, col=xtra)
text(x, y-0.8, txt, adj=0)
}
text(farleft-0.75, ycol[1]-1.0,
expression("Selected schemes from the "*italic("dichromat")*
" package, "* "e.g. colorshemes$GreentoMagenta.16"), adj=0)
plot.palette(y=ycol[2], colr="GreentoMagenta.16", dichrom=TRUE,
x=farleft+0.25)
plot.palette(y=ycol[3], colr="BluetoGreen.14", dichrom=TRUE,
x=farleft+0.25)
plot.palette(y=ycol[4], colr="BluetoOrangeRed.14", dichrom=TRUE,
x=farleft+0.25)
plot.palette(y=ycol[5], colr="DarkRedtoBlue.12", dichrom=T,
x=farleft+0.25)
plot.palette(y=ycol[6], colr="BluetoOrange.12", dichrom=T,
x=farleft+0.25)
plot.palette(y=ycol[7], colr="DarkRedtoBlue.12", dichrom=T,
x=farleft+0.25)
plot.palette(y=ycol[8], colr="BluetoDarkOrange.12", dichrom=T,
x=farleft+0.25)
plot.palette(y=ycol[9], colr="BrowntoBlue.12", dichrom=TRUE,
txt="BrowntoBlue.12", x=farleft+0.25)
plot.palette(y=ycol[10], colr="BluetoGray.8", dichrom=T,
x=farleft+0.25)
plot.palette(y=ycol[11], colr="BluetoOrange.8", dichrom=T,
x=farleft+0.25)
plot.palette(y=ycol[12], colr="LightBluetoDarkBlue.7", dichrom=T,
x=farleft+0.25)
plot.palette(y=ycol[13], colr="SteppedSequential.5", dichrom=T,
x=farleft+0.25)
text(farleft-0.75, ycol[14]-1.0,
"Simulation of Effects of Two Common types of Red-Green Color Blindness",
adj=0)
plot.palette(y=ycol[15], colr=c(palette()), x=farleft+0.25, x0=4.65,
xtra="green", txt="Default palette + green")
plot.palette(y=ycol[16], colr=c(palette()), x=farleft+0.25, x0=4.65,
xtra="green", txt="Default palette + green", simulate="deutan")
plot.palette(y=ycol[17], colr=c(palette()), x=farleft+0.25, x0=4.65,
txt="Default palette + green", xtra="green", simulate="protan")
plot.palette(y=ycol[18], colr="Categorical.12", dichrom=T, x0=4.65,
txt=expression("Categorical.12 "*italic("(dichromat)")),
x=farleft+0.25)
plot.palette(y=ycol[19], colr="Categorical.12", dichrom=T, x0=4.65,
txt="Categorical.12", x=farleft+0.25, simulate="deutan")
plot.palette(y=ycol[20], colr="Categorical.12", dichrom=T, x0=4.65,
txt="Categorical.12", x=farleft+0.25,
simulate="protan")
if(device!="")dev.off()
}
gcol15 <-
function(width=9.25, height=5, pointsize=c(8,5), device=""){
if(device!="") hardcopy(width=width, height=height, trellis=T,
color=TRUE, horiz=TRUE,
pointsize=pointsize, device=device)
if(!require(latticeExtra))return("Package 'lattice' is not installed -- cannot proceed")
if(!require(DAAGxtras))return("Package 'DAAGxtras' is not installed -- cannot proceed")
CO2smu <- with(edcCO2, supsmu(age, co2, span=.005))
tempsmu <- with(edcT, supsmu(Age, dT, span=.001))
co2_layer <- xyplot(y ~ I(-x), data=CO2smu, type="l",
xlab="Years Before Present",
ylab = expression(CO[2]*" (ppm)"))
temp_layer <- xyplot(I(y+54.5) ~ I(-x), data=tempsmu, type="l",
ylab=expression("Temperature ("*degree*C*")"))
print(doubleYScale(co2_layer, temp_layer, add.ylab2 = TRUE))
if(device!="")dev.off()
}
pkgs <- c("latticeExtra","DAAG", "RColorBrewer", "dichromat", "grid", "hddplot","DAAGbio",
"randomForest","MASS","splines","limma")
z <- sapply(pkgs, require, character.only=TRUE, warn.conflicts=FALSE, quietly=TRUE)
## randomForest 4.6-10
## Type rfNews() to see new features/changes/bug fixes.
if(any(!z)){
notAvail <- paste(names(z)[!z], collapse=", ")
stop(paste("The following packages should be installed:", notAvail))
}
gcol1()
gcol2()
gcol3()
gcol4()
gcol5()
gcol6()
gcol7()
## [1] 1
gcol8()
##
## Preliminary per fold calculations
## 1:2:3:4:5:6:7:8:9:10:
## Show each choice of number of features:
## 1:2:3:4:5:6:7:8:9:10:11:12:13:14:15:16:17:18:19:20:21:22:23:
##
## Accuracy Best accuracy, less 1SD Best accuracy
## (Cross-validation) 0.85 (3 features) 0.9 (4 features)
## 1:2:3:4:5:6:7:8:9:10
## 1:2:3:4:5:6:7:8:9:10
##
## Preliminary per fold calculations
## 1:2:3:4:5:6:7:8:9:10:1:2:3:4:5:6:7:8:9:10:1:2:3:4:5:6:7:8:9:10:1:2:3:4:5:6:7:8:9:10:
## Show each choice of number of features:
## 1:2:3:4:5:6:7:8:9:10:11:12:13:14:15:16:17:18:19:20:21:22:23:
##
## Accuracy Best accuracy, less 1SD Best accuracy
## (Cross-validation) 0.9 (19 features) 0.94 (23 features)
## 1:2:3:4:5:6:7:8:9:101:2:3:4:5:6:7:8:9:101:2:3:4:5:6:7:8:9:101:2:3:4:5:6:7:8:9:10
## 1:2:3:4:5:6:7:8:9:101:2:3:4:5:6:7:8:9:101:2:3:4:5:6:7:8:9:101:2:3:4:5:6:7:8:9:10
gcol9()
gcol10()
gcol11()
##
## Control (psid1) Treated (experimental)
## 328 283
## Warning: variables are collinear
gcol12()
gcol13()
gcol15()
## Loading required package: DAAGxtras
##
## Attaching package: 'DAAGxtras'
##
## The following objects are masked from 'package:DAAG':
##
## plotSampDist, simulateSampDist
