lattice 的几种方法来完成这个任务。你可以使用 xyplot 并使用 panel.fill 填充面板，或者你可以使用 levelplot。多边形本身必须通过自定义面板和 lpolygon 添加。以下是我使用 levelplot 的方法。虽然我真的是一个 lattice 新手，但可能还有一些我不知道的快捷方式。levelplot，所以我们首先创建一个矩阵，其中包含每个 MEANSES 和 SES 组合的中位数 MathAch 分数。这些将用于绘制单元格颜色。library(lattice)
library(nlme)
data(MathAchieve)
下面，我使用 cut 将 SES 和 MEANSES 转换为因子，断点与维基百科示例相同。
MathAchieve$SESfac <- as.numeric(cut(MathAchieve$SES, seq(-2.5, 2, 0.5)))
MathAchieve$MEANSESfac <- as.numeric(cut(MathAchieve$MEANSES,
seq(-1.25, 1, 0.25)))
我不确定如何像维基百科页面上那样绘制四个面板，因此我将仅对非少数族裔女性进行子集：
d <- subset(MathAchieve, Sex=='Female' & Minority=='No')
SESfac和MEANSESfac的中位数MathAch。l <- split(d$MathAch, list(d$SESfac, d$MEANSESfac))
m.median <- matrix(sapply(l, median), ncol=9)
levelplot时，我们将可以访问x和y，它们是“当前”单元格的坐标。为了将MathAch向量传递给levelplot，以便为每个单元格绘制多边形，我创建了一个列表矩阵（与m.median相同的尺寸），其中每个单元格都是包含MathAch向量的列表。m <- matrix(l, ncol=9)
colramp <- colorRampPalette(c('#fff495', '#bbffaa', '#70ffeb', '#72aaff',
'#bf80ff'))
fanplot <- function(x, y, z, subscripts, fans, ymin, ymax,
nmax=max(sapply(fans, length)), ...) {
# nmax is the maximum sample size across all combinations of conditioning
# variables. For generality, ymin and ymax are limits of the circle around
# around which fancharts are plotted.
# fans is our matrix of lists, which are used to plot polygons.
get.coords <- function(a, d, x0, y0) {
a <- ifelse(a <= 90, 90 - a, 450 - a)
data.frame(x = x0 + d * cos(a / 180 * pi),
y = y0 + d * sin(a / 180 * pi))
}
# getcoords returns coordinates of one or more points, given angle(s),
# (i.e., a), distances (i.e., d), and an origin (x0 and y0).
panel.levelplot(x, y, z, subscripts, ...)
# Below, we scale the raw vectors of data such that ymin thru ymax map to
# 0 thru 360. We then calculate the relevant quantiles (i.e. 25%, 50% and 75%).
smry <- lapply(fans, function(y) {
y.scld <- (y - ymin)/(ymax - ymin) * 360
quantile(y.scld, c(0.25, 0.5, 0.75)) - 90
})
# Now we use get.coords to determine relevant coordinates for plotting
# polygons and lines. We plot a white line inwards from the circle's edge,
# with length according to the ratio of the sample size to nmax.
mapply(function(x, y, smry, n) {
if(!any(is.na(smry))) {
lpolygon(rbind(c(x, y),
get.coords(seq(smry['25%'], smry['75%'], length.out=200),
0.3, x, y)), col='gray10', lwd=2)
llines(get.coords(c(smry['50%'], 180 + smry['50%']), 0.3,
x, y), col=1, lwd=3)
llines(get.coords(smry['50%'], c(0.3, (1 - n/nmax) * 0.3),
x, y), col='white', lwd=3)
}
}, x=x, y=y, smry=smry, n=sapply(fans, length))
}
最后，在 levelplot 中使用此自定义面板函数：
levelplot(m.median, fans=m, ymin=0, ymax=28,
col.regions=colramp, at=seq(0, 25, 5), panel=fanplot,
scales=list(tck=c(1, 0),
x=list(at=seq_len(ncol(m.median) + 1) - 0.5,
labels=seq(-2.5, 2, 0.5)),
y=list(at=seq_len(nrow(m.median) + 1) - 0.5,
labels=seq(-1.25, 1, 0.25))),
xlab='Socio-economic status of students',
ylab='Mean socio-economic status for the school')
如果需要，我可以使用 lrect 来将样本量小于 7 的单元格涂成灰色，就像 维基百科页面 上的相应图表一样。
在我之前的回答中，我思考了一下，想出了一种更简单的方法来生成多面板（如果适用）风扇图，并叠加在 levelplot 上，如维基百科风扇图页面所示。此方法适用于具有两个独立变量和零个或多个调节变量将数据分成面板的 data.frame。
首先，我们定义一个新的面板函数，panel.fanplot。
panel.fanplot <- function(x, y, z, zmin, zmax, subscripts, groups,
nmax=max(tapply(z, list(x, y, groups),
function(x) sum(!is.na(x))), na.rm=T),
...) {
if(missing(zmin)) zmin <- min(z, na.rm=TRUE)
if(missing(zmin)) zmax <- max(z, na.rm=TRUE)
get.coords <- function(a, d, x0, y0) {
a <- ifelse(a <= 90, 90 - a, 450 - a)
data.frame(x = x0 + d * cos(a / 180 * pi),
y = y0 + d * sin(a / 180 * pi))
}
z.scld <- (z - zmin)/(zmax - zmin) * 360
fan <- aggregate(list(z=z.scld[subscripts]),
list(x=x[subscripts], y=y[subscripts]),
function(x)
c(n=sum(!is.na(x)),
quantile(x, c(0.25, 0.5, 0.75), na.rm=TRUE) - 90))
panel.levelplot(fan$x, fan$y,
(fan$z[, '50%'] + 90) / 360 * (zmax - zmin) + zmin,
subscripts=seq_along(fan$x), ...)
lapply(which(!is.na(fan$z[, '50%'])), function(i) {
with(fan[i, ], {
poly <- rbind(c(x, y),
get.coords(seq(z[, '25%'], z[, '75%'], length.out=200),
0.3, x, y))
lpolygon(poly$x, poly$y, col='gray10', border='gray10', lwd=3)
llines(get.coords(c(z[, '50%'], 180 + z[, '50%']), 0.3, x, y),
col='black', lwd=3, lend=1)
llines(get.coords(z[, '50%'], c(0.3, (1 - z[, 'n']/nmax) * 0.3), x, y),
col='white', lwd=3)
})
})
}
levelplot：d <- data.frame(z=runif(1000),
x=sample(5, 1000, replace=TRUE),
y=sample(5, 1000, replace=TRUE),
grp=sample(4, 1000, replace=TRUE))
colramp <- colorRampPalette(c('#fff495', '#bbffaa', '#70ffeb', '#72aaff',
'#bf80ff'))
levelplot(z ~ x*y|as.factor(grp), d, groups=grp, asp=1, col.regions=colramp,
panel=panel.fanplot, zmin=min(d$z, na.rm=TRUE),
zmax=max(d$z, na.rm=TRUE), at=seq(0, 1, 0.2))
group将筛选变量（将图形分成面板）传递给levelplot，如上所示使用变量grp，以便计算样本大小（由白线长度表示）。
以下是如何模仿维基百科的情况：
library(nlme)
data(MathAchieve)
MathAchieve$SESfac <- as.numeric(cut(MathAchieve$SES, seq(-2.5, 2, 0.5)))
MathAchieve$MEANSESfac <-
as.numeric(cut(MathAchieve$MEANSES, seq(-1.25, 1, 0.25)))
levels(MathAchieve$Minority) <- c('Non-minority', 'Minority')
MathAchieve$group <-
as.factor(paste0(MathAchieve$Sex, ', ', MathAchieve$Minority))
colramp <- colorRampPalette(c('#fff495', '#bbffaa', '#70ffeb', '#72aaff',
'#bf80ff'))
levelplot(MathAch ~ SESfac*MEANSESfac|group, MathAchieve,
groups=group, asp=1, col.regions=colramp,
panel=panel.fanplot, zmin=0, zmax=28, at=seq(0, 25, 5),
scales=list(alternating=1,
tck=c(1, 0),
x=list(at=seq(1, 11) - 0.5,
labels=seq(-2.5, 2, 0.5)),
y=list(at=seq(1, 11) - 0.5,
labels=seq(-1.25, 1, 0.25))),
between=list(x=1, y=1), strip=strip.custom(bg='gray'),
xlab='Socio-economic status of students',
ylab='Mean socio-economic status for school')
plotrix包具有大量专业的图表功能。 - IRTFM