Question

如何绘制this Wikipedia page上显示的粉丝图？

我已将nlme软件包及其MathAchieve数据集安装，但我找不到用于绘制此图表的命令。

nlme pdf文件为here。

我还检查了this link，但它不是英文。

使用fan.plot包中的plotrix函数，我只能绘制饼图： https://sites.google.com/site/distantyetneversoclose/excel-charts/the-pie-doughnut-combination-a-fan-plot

感谢您的帮助。

Answer 1

我可以想到用lattice来解决这个问题的几种方法。您可以使用xyplot并使用panel.fill填充面板，也可以使用levelplot。必须使用自定义面板lpolygon添加多边形本身。这是我用levelplot完成的方式。不过，我真的是一个lattice新手，而且很可能会有一些我不知道的快捷方式。

因为我正在使用levelplot，所以我们首先为MathAch和MEANSES的每个组合创建一个包含中位数SES得分的矩阵。这些将用于绘制单元格颜色。

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')

enter image description here

如果样本大小，我没有将细胞染成灰色。 7，与Wikipedia page上的等效图一样，但如果需要，可以使用lrect完成。

Answer 2

自从我之前的回答以来，我已经考虑了这个问题，我已经提出了一种更简单的方法来生成多面板（如果适用）的扇形图，覆盖在levelplot上，如{{1}所示。 3}}。这种方法适用于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，按顺序排列用于计算样本大小（以白线长度显示）。

fanplot1

以下是我们如何模仿维基百科的情节：

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')

fanplot2

如何在维基百科页面上绘制粉丝图

2 个答案: