graphics.txt

里面有三个PDF文件

        } 
        if (!pi2.lab & is.null(text.lab) & is.numeric(num.lab)) { 
            labDir <- seq(0, 2 * pi, length = num.lab + 1)[-(num.lab + 
                1)] 
            labDir <- fit.rad(theta.zero + (!theta.clw) * labDir - 
                (theta.clw) * labDir) 
            text(lab.dist * cos(labDir), lab.dist * sin(labDir), 
                paste(num.lab * labDir/(2 * pi)), cex = tlabel.cex, 
                col = tlabel.col) 
        } 
        if ((is.character(text.lab) & is.numeric(num.lab)) || 
            (is.character(text.lab) & pi2.lab) || (pi2.lab & 
            is.numeric(num.lab))) 
            print("More than one type of angular labels was requested.") 
    } 
    theta2 <- fit.rad(theta.zero + (!theta.clw) * theta - (theta.clw) * 
        theta) 
    cartesian.rt <- cbind(r * cos(theta2), r * sin(theta2)) 
    if (method == 1) { 
        if (is.null(overlay) || overlay == 2) 
            drawgrid() 
        points(cartesian.rt[, 1], cartesian.rt[, 2], col = lp.col, 
            pch = points.pch, cex = points.cex) 
    } 
    if (method == 2) { 
        if (is.null(overlay) || overlay == 2) 
            drawgrid() 
        lines(cartesian.rt[, 1], cartesian.rt[, 2], lwd = lines.lwd, 
            col = lp.col, lty = lines.lty) 
    } 
    if ((method == 2 || method == 3) & length(r) <= 1) 
        print("More than one data point is needed for line and polygon methods.") 
    if (method == 3) { 
        if (!polygon.bottom & (is.null(overlay) || overlay == 
            2)) 
            drawgrid() 
        polygon(cartesian.rt, lwd = lines.lwd, col = polygon.col, 
            border = lp.col, lty = lines.lty) 
        if (polygon.bottom & (is.null(overlay) || overlay == 
            2)) 
            drawgrid() 
    } 
} 




#
# Comment:
#
# Examples using high-level plotting functions from the packages 
# "graphics", "CircStats", and "vcd", plus code contributed in an
# email on the R-help mailing list by Kartsen Bjerre (above).
#
# In each case, additional output has been used to slightly
# customize the output from the plotting function and/or 
# the arguments of the plotting function have been used to
# achieve a non-default appearance for the plot.
#


par(mfrow=c(2, 2), xpd=NA)
# Example 3 from stars
data(mtcars)
     stars(mtcars[, 1:7], locations = c(0,0), radius = FALSE,
           key.loc=c(0,0), main="Motor Trend Cars",
           col.stars=grey(1:32/33))
points(0, 0, pch=16)
# karstenbjerre polar plot
par(mar=rep(1, 4))
div<-50
theta <- seq(0, 2 * pi, length = div + 1)[-(div+1)] 
r<-1:(div) 
textlabels<-c('N','E','S','W')
par(lwd=.1)
polar.plot(r, theta, theta.clw = TRUE, theta.zero = pi/2, 
           text.lab = textlabels , pi2.lab = FALSE, lines.lwd = 3, 
           grid.lwd = 1, grid.col = "grey", rlabel.method = 2, 
           rlabel.axis = pi/2, rlabel.pos = NULL,  
           points.pch = 21, tlabel.offset = 0.3) 
par(lwd=1)
# example 2 from rose.diag from CircStats package
library(CircStats)
data <- runif(50, 0, 2*pi)
par(cex=0.5, mar=rep(1, 4))
rose.diag(data, bins = 18, pts=TRUE, prop=2, shrink=1.2)
par(cex=1)

# Ternary plot
# Based on example 1 of help(ternaryplot)
library(vcd)
par(cex=0.5)
data(Arthritis)

# Build table by crossing Treatment and Sex
tab <- as.table(xtabs(~ I(Sex:Treatment) + Improved, data = Arthritis))

# Mark groups
col <- c("black", "black", "black", "black")
pch <- c(1, 19, 0, 15)

# plot
ternaryplot(tab,
            col = col,
            border="grey",
            pch = pch,
            prop.size = TRUE,
            bg = "white",
            grid="solid",
            grid.color = "grey",
            labels.color = "grey",
            main = "")

detach("package:vcd")

##############################################################################
7>Figure 1.7 
A novel decision tree plot 
library(party)

# CLASSIFICATION
# fitting
library(ipred)
data(GlaucomaM)
glau <- GlaucomaM
levels(glau$Class) <- c("glau", "norm")
fm.class <- ctree(Class ~ ., data = glau)

# visualization
pushViewport(viewport(gp=gpar(cex=0.6)))
plot(fm.class, new=FALSE, terminal.panel=myNode)
popViewport()

##############################################################################
8>Figure 1.8 
A table-like plot 
#
# Comment:
#
# Some simple ideas as a basis for meta-analysis plots.
# 
# The code is modular so that something similar could be achieved
# with different data quite simply.  The actual drawing for these data
# only occurs in the last 10 or so lines of code.
#


# The horizontal gap between columns with content
colgap <- unit(3, "mm")

# The data for column 1
# 
# Of course, many other possible ways to represent the data
# One advantage with this way is that col1$labels can be used
# directly in the calculation of the column widths for the
# main table (see below)
#
# NOTE:  textGrobs are used here so that the fontface (bold in
# some cases) is associated with the label.  In this way, the
# calculation of column widths takes into account the font face.
col1 <- list(labels=
             list(textGrob("Centre", x=0, just="left",
                           gp=gpar(fontface="bold")),
                  textGrob("Thailand", x=0, just="left"),
                  textGrob("Philippines", x=0, just="left"),
                  textGrob("All in situ", x=0, just="left",
                           gp=gpar(fontface="bold")),
                  textGrob("Colombia", x=0, just="left"),
                  textGrob("Spain", x=0, just="left"),
                  textGrob("All invasive", x=0, just="left",
                           gp=gpar(fontface="bold")),
                  textGrob("All", x=0, just="left",
                           gp=gpar(fontface="bold"))),
             rows=c(1, 5, 6, 8, 11, 12, 14, 16))

# Labels in col 1 which are not used to calculate the
# column width (they spill over into col 2)
col1plus <- list(labels=
                 list(textGrob("Carcinoma in situ", x=0, just="left",
                               gp=gpar(fontface="bold")),
                      textGrob("Invasive cancer", x=0, just="left",
                               gp=gpar(fontface="bold"))),
                 rows=c(4, 10))

# Data for column 2
col2 <- list(labels=
             list(textGrob("cases", x=1, just="right",
                           gp=gpar(fontface="bold")),
                  textGrob("327", x=1, just="right"),
                  textGrob("319", x=1, just="right"),
                  textGrob("1462", x=1, just="right",
                           gp=gpar(fontface="bold")),
                  textGrob("96", x=1, just="right"),
                  textGrob("115", x=1, just="right"),
                  textGrob("211", x=1, just="right",
                           gp=gpar(fontface="bold")),
                  textGrob("1673", x=1, just="right",
                           gp=gpar(fontface="bold"))),
             rows=c(1, 5, 6, 8, 11, 12, 14, 16))

# Data for column 3 (width specified as a physical size below)
col3 <- list(OR=c(0.72, 1.27, 1.17, 2.97, 1.86, 2.01, 1.20),
             LL=c(0.52, 0.87, 1.03, 1.42, 0.46, 1.09, 1.07),
             UL=c(1.00, 1.85, 1.32, 6.21, 7.51, 3.71, 1.35),
             rows=c(5, 6, 8, 11, 12, 14, 16),
             # "s" means summary, "n" means normal
             type=c("n", "n", "s", "n", "n", "s", "s"))

# Sizes of boxes
information <- sqrt(1 / ((log(col3$UL) - log(col3$OR))/1.96))
col3$sizes <- information/max(information)

# Width of column 3
col3width <- unit(1.5, "inches")

# Range on the x-axis for column 3
col3$range <- c(0, 4)

# Function to draw a cell in a text column
drawLabelCol <- function(col, j) {
  for (i in 1:length(col$rows)) {
    pushViewport(viewport(layout.pos.row=col$rows[i], layout.pos.col=j))
    # Labels are grobs containing their location so just
    # have to grid.draw() them
    grid.draw(col$labels[[i]])
    popViewport()
  }
}

# Function to draw a non-summary rect-plus-CI
drawNormalCI <- function(LL, OR, UL, size) {
  # NOTE the use of "native" units to position relative to
  # the x-axis scale, and "snpc" units to size relative to
  # the height of the row
  # ("snpc" stands for "square normalised parent coordinates"
  #  which means that the value is calculated as a proportion
  #  of the width and height of the current viewport and the
  #  physically smaller of these is used)
  grid.rect(x=unit(OR, "native"),
            width=unit(size, "snpc"), height=unit(size, "snpc"),
            gp=gpar(fill="black"))
  # Draw arrow if exceed col range
  # convertX() used to convert between coordinate systems
  if (convertX(unit(UL, "native"), "npc", valueOnly=TRUE) > 1)
    grid.arrows(x=unit(c(LL, 1), c("native", "npc")),
                length=unit(0.05, "inches"))
  else {
    # Draw line white if totally inside rect
    lineCol <- if ((convertX(unit(OR, "native") + unit(0.5*size, "lines"),
                             "native", valueOnly=TRUE) > UL) &&
                   (convertX(unit(OR, "native") - unit(0.5*size, "lines"),
                             "native", valueOnly=TRUE) < LL))
      "white"
    else
      "black"
    grid.lines(x=unit(c(LL, UL), "native"), y=0.5,
               gp=gpar(col=lineCol))
  }
}

# Function to draw a summary "diamond"
drawSummaryCI <- function(LL, OR, UL, size) {
  # Not sure how to calc the heights of the diamonds so
  # I'm just using half the height of the equivalent rect
  grid.polygon(x=unit(c(LL, OR, UL, OR), "native"),
               y=unit(0.5 + c(0, 0.25*size, 0, -0.25*size), "npc"))
}

# Function to draw a "data" column
drawDataCol <- function(col, j) {
  pushViewport(viewport(layout.pos.col=j, xscale=col$range))
  grid.lines(x=unit(1, "native"), y=0:1)
  # Assume that last value in col is "All"
  grid.lines(x=unit(col$OR[length(col$OR)], "native"),
             y=0:1, gp=gpar(lty="dashed"))
  grid.xaxis(gp=gpar(cex=0.6))
  grid.text("OR", y=unit(-2, "lines"))
  popViewport()
  for (i in 1:length(col$rows)) {
    pushViewport(viewport(layout.pos.row=col$rows[i], layout.pos.col=j,
                          xscale=col$range))
    if (col$type[i] == "n")
      drawNormalCI(col$LL[i], col$OR[i], col$UL[i], col$sizes[i])
    else
      drawSummaryCI(col$LL[i], col$OR[i], col$UL[i], col$sizes[i])
    popViewport()
  }
}

# Draw the table
#
# The table is just a big layout
#
# All rows are the height of 1 line of text
# 
# Widths of column 1 and 2 are based on widths of labels in
# col$labels and col2$labels 
pushViewport(viewport(layout=grid.layout(16, 5,
                        widths=
                        unit.c(max(unit(rep(1, 8), "grobwidth", col1$labels)),
                               colgap,
                               max(unit(rep(1, 8), "grobwidth", col2$labels)),
                               colgap,
                               col3width),
                        heights=unit(rep(1, 16), "lines"))))
drawLabelCol(col1, 1)
drawLabelCol(col1plus, 1)
drawLabelCol(col2, 3)
drawDataCol(col3, 5)
popViewport()
#################################################################################                         
9>Figure 1.9 
Didactic diagrams 
#
# Comment:
#
# Code by Arden Miller (Department of Statistics, The University of Auckland).
# 
# Lots of coordinate transformations being done "by hand".
# This code is not really reusable;  just a demonstration that very 
# pretty results are possible if you're sufficiently keen.
#


par(mfrow=c(2, 1), pty="s", mar=rep(1, 4)) 
# Create plotting region and plot outer circle
plot(c(-1.1, 1.2), c(-1.1, 1.2),
     type="n", xlab="", ylab="", 
     xaxt="n", yaxt="n", cex.lab=2.5)
angs <- seq(0, 2*pi, length=500)
XX <- sin(angs)
YY <- cos(angs)
lines(XX, YY, type="l")

# Set constants
phi1 <- pi*2/9
k1 <- sin(phi1)
k2 <- cos(phi1)

# Create grey regions
obsphi <- pi/12
lambdas <- seq(-pi, pi, length=500)
xx <- cos(pi/2 - obsphi)*sin(lambdas)
yy <- k2*sin(pi/2 - obsphi)-k1 * cos(pi/2 - obsphi)*cos(lambdas)
polygon(xx, yy, col="grey")
lines(xx, yy, lwd=2)
theta1sA <- seq(-obsphi, obsphi, length=500)
theta2sA <- acos(cos(obsphi)/cos(theta1sA))
theta1sB <- seq(obsphi, -obsphi, length=500)
theta2sB <-  -acos(cos(obsphi)/cos(theta1sB))
theta1s <- c(theta1sA, theta1sB)
theta2s <- c(theta2sA, theta2sB)
xx <- cos(theta1s)*sin(theta2s+pi/4)
yy <- k2*sin(theta1s)-k1*cos(theta1s)*cos(theta2s+pi/4)
polygon(xx, yy, col="grey")
lines(xx, yy, lwd=2)
xx <- cos(theta1s)*sin(theta2s-pi/4)
yy <- k2*sin(theta1s)-k1*cos(theta1s)*cos(theta2s-pi/4)
polygon(xx, yy, col="grey")
lines(xx, yy, lwd=2)

# Plot longitudes
vals <- seq(0, 7, 1)*pi/8
for(lambda in vals){
sl <- sin(lambda)
cl <- cos(lambda)
phi <- atan(((0-1)*k2*cl)/(k1))
angs <- seq(phi, pi+phi, length=500)
xx <- cos(angs)*sl
yy <- k2*sin(angs)-k1*cos(angs)*cl
lines(xx, yy, lwd=.5)
}

# Grey out polar cap
phi <- 5.6*pi/12
lambdas <- seq(-pi, pi, length=500)
xx <- cos(phi)*sin(lambdas)
yy <- k2*sin(phi)-k1 * cos(phi)*cos(lambdas)
polygon(xx, yy, col="grey")

# Plot Latitudes
vals2 <- seq(-2.8, 5.6, 1.4)*pi/12
for(phi in vals2){
  if (k1*sin(phi) > k2 * cos(phi)) 
    crit <- pi 
  else 
    crit <- acos((-k1*sin(phi))/(k2*cos(phi)))
  lambdas <- seq(-crit, crit, length=500)
  xx <- cos(phi)*sin(lambdas)
  yy <- k2*sin(phi)-k1 * cos(phi)*cos(lambdas)
  lines(xx, yy, lwd=.5)
}


# Plots axes and label
lines(c(0.00, 0.00), c(k2*sin(pi/2), 1.11), lwd=4)
lines(c(0.00, 0.00), c(-1, -1.12), lwd=4)
a2x <- sin(-pi/4)
a2y <- cos(-pi/4)*(-k1)
lines(c(a2x, 1.5*a2x), c(a2y, 1.5*a2y), lwd=4)
k <- sqrt(a2x^2+a2y^2)
lines(c(-a2x/k, 1.2*(-a2x/k)), c(-a2y/k, 1.2*(-a2y/k)), lwd=4)
a3x <- sin(pi/4)
a3y <- cos(pi/4)*(-k1)
lines(c(a3x, 1.5*a3x), c(a3y, 1.5*a3y), lwd=4)
k <- sqrt(a3x^2+a3y^2)
lines(c(-a3x/k, 1.2*(-a3x/k)), c(-a3y/k, 1.2*(-a3y/k)), lwd=4)
text(0.1, 1.12, expression(bold(X[1])))
text(-1.07, -.85, expression(bold(X[2])))
text(1.11, -.85, expression(bold(X[3])))

# set plot region and draw outer circle
plot(c(-1.1, 1.2),  c(-1.1, 1.2),
     type="n", xlab="", ylab="", 
     xaxt="n", yaxt="n", cex.lab=2.5)
angs <- seq(0, 2*pi, length=500)
XX <- sin(angs)
YY <- cos(angs)
lines(XX, YY, type="l")

# set constants
phi1 <- pi*2/9
k1 <- sin(phi1)
k2 <- cos(phi1)
obsphi <- pi/24

# create X2X3 grey region and plot boundary
crit <- acos((-k1*sin(obsphi))/(k2 * cos(obsphi)))
lambdas <- seq(-crit, crit, length=500)
xx1 <- cos(obsphi)*sin(lambdas)
yy1 <- k2*sin(obsphi)-k1 * cos(obsphi)*cos(lambdas)
obsphi <-  -pi/24
crit <- acos((-k1*sin(obsphi))/(k2 * cos(obsphi)))
lambdas <- seq(crit, -crit, length=500)
xx3 <- cos(obsphi)*sin(lambdas)
yy3 <- k2*sin(obsphi)-k1 * cos(obsphi)*cos(lambdas)
ang1 <-  atan(xx1[500]/yy1[500])
ang2 <- pi+atan(xx3[1]/yy3[1])
angs <- seq(ang1, ang2, length=50)
xx2 <- sin(angs)
yy2 <- cos(angs)
ang4 <-  atan(xx1[1]/yy1[1])
ang3 <-  -pi+ atan(xx3[500]/yy3[500])
angs <- seq(ang3, ang4, length=50)
xx4 <- sin(angs)
yy4 <- cos(angs)
xxA <- c(xx1, xx2, xx3, xx4)
yyA <- c(yy1, yy2, yy3, yy4)
polygon(xxA, yyA, border="grey", col="grey")
xx1A <- xx1
yy1A <- yy1
xx3A <- xx3
yy3A <- yy3