如何在维基百科页面上绘制粉丝图
如何绘制此维基百科页面上显示的粉丝图？
我已经nlme使用其MathAchieve数据集安装了包,但是我找不到用于绘制此图的命令.
该nlmePDF文件是在这里.
我也检查了这个链接,但它不是英文的.
使用包中的fan.plot功能plotrix,我只能绘制饼图:https:
//sites.google.com/site/distantyetneversoclose/excel-charts/the-pie-doughnut-combination-a-fan-plot
谢谢你的帮助.
我可以想到几种方法来解决这个问题lattice.您可以使用xyplot和填充面板panel.fill,也可以使用levelplot.多边形本身必须添加自定义面板和lpolygon.这是我如何做到的levelplot.lattice不过,我真的是个新手,而且很可能会有一些我不知道的捷径.
因为我正在使用levelplot,我们首先创建一个矩阵,其中包含和的MathAch每个组合的中位数分数.这些将用于绘制单元格颜色.MEANSESSES
library(lattice)
library(nlme)
data(MathAchieve)
下面,我使用断点来转换SES和MEANSES使用因子cut,如维基百科示例中所示.
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')
要将此数据帧转换为矩阵,我将split其转换为列表,然后强制返回具有适当尺寸的矩阵.矩阵的每个单元包含中值MathAch用于的特定组合SESfac和MEANSESfac.
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)
下面我们在维基百科的例子中创建一个Wolfram Fischer使用的颜色渐变.
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')
如果样本大小<7,我没有将单元格变成灰色,就像维基百科页面上的等效图一样,但lrect如果需要,可以这样做.
自从我之前的回答以来,我已经考虑了这个问题,我想出了一种更简单的方法来制作多面板(如果合适的)扇形图,覆盖在a上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))
重要的是将条件变量(将图分隔成面板)levelplot通过参数传递group,如上面的变量所示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')
