移除QQ图中心附近的多余点

我正在尝试在R中绘制一个带有两个约120万个点的数据集的QQ图（使用qqplot，并将数据输入到ggplot2中）。计算很容易，但是由于有很多点，因此生成的图形加载起来非常缓慢。我尝试了线性逼近以将点的数量减少到10000（无论如何，如果您的数据集之一大于另一个，这就是qqplot函数所做的事情），但是您会损失很多细节。

指向中心的大多数数据点基本上是无用的-它们重叠得太多，以致每个像素大概有100个。是否有任何简单的方法可以删除过于紧密的数据，而又不会使稀疏的数据流向尾部呢？

QQ情节具有令人难以置信的自相关，除了尾部。在审查它们时，人们将重点放在情节的整体形状和尾巴行为上。 如此，您可以通过在分布的中心进行粗抽样并包含足够数量的尾部来进行精细处理。

以下代码说明了如何在整个数据集中进行采样以及如何获取极值。

quant.subsample <- function(y, m=100, e=1) {
  # m: size of a systematic sample
  # e: number of extreme values at either end to use
  x <- sort(y)
  n <- length(x)
  quants <- (1 + sin(1:m / (m+1) * pi - pi/2))/2
  sort(c(x[1:e], quantile(x, probs=quants), x[(n+1-e):n]))
  # Returns m + 2*e sorted values from the EDF of y
}

为了说明这一点，该模拟数据集显示了两个数据集之间的结构差异，这些数据集大约有120万个值，并且其中一个中的污染物极少。另外，为了使该测试更加严格，从一个数据集中完全排除了一个值的间隔：QQ图需要显示这些值的中断。

set.seed(17)
n.x <- 1.21 * 10^6
n.y <- 1.20 * 10^6
k <- floor(0.0001*n.x)
x <- c(rnorm(n.x-k), rnorm(k, mean=2, sd=2))
x <- x[x <= -3 | x >= -2.5]
y <- rbeta(n.y, 10,13)

我们可以对每个数据集进行0.1％的二次抽样，并再添加其极端值的0.1％，从而得出2420个点。总耗时少于0.5秒：

m <- .001 * max(n.x, n.y)
e <- floor(0.0005 * max(n.x, n.y))

system.time(
  plot(quant.subsample(x, m, e), 
       quant.subsample(y, m, e), 
       pch=".", cex=4,
       xlab="x", ylab="y", main="QQ Plot")
  )

不会丢失任何信息：

在该线程的其他地方，我提出了一个简单但有些特殊的方法，对点进行二次采样。它的速度很快，但需要进行一些实验才能得出理想的情节。将要描述的解决方案要慢一个数量级（120万个点最多需要10秒），但是是自适应的并且是自动的。对于大型数据集，它应该在第一时间给出良好的结果，并且要相当快地这样做。

$D_n$

$(x,y)$$t$$y$

有一些细节需要注意，尤其是处理不同长度的数据集时。我通过用对应于较长的分位数的分位数替换较短的分位数来做到这一点：实际上，使用了较短的分位数的EDF的分段线性近似，而不是其实际数据值。（通过设置可以反转“更短”和“更长”use.shortest=TRUE。）

这是一个R实现。

qq <- function(x0, y0, t.y=0.0005, use.shortest=FALSE) {
  qq.int <- function(x,y, i.min,i.max) {
    # x, y are sorted and of equal length
    n <-length(y)
    if (n==1) return(c(x=x, y=y, i=i.max))
    if (n==2) return(cbind(x=x, y=y, i=c(i.min,i.max)))
    beta <- ifelse( x[1]==x[n], 0, (y[n] - y[1]) / (x[n] - x[1]))
    alpha <- y[1] - beta*x[1]
    fit <- alpha + x * beta
    i <- median(c(2, n-1, which.max(abs(y-fit))))
    if (abs(y[i]-fit[i]) > thresh) {
      assemble(qq.int(x[1:i], y[1:i], i.min, i.min+i-1), 
               qq.int(x[i:n], y[i:n], i.min+i-1, i.max))
    } else {
      cbind(x=c(x[1],x[n]), y=c(y[1], y[n]), i=c(i.min, i.max))
    }
  }
  assemble <- function(xy1, xy2) {
    rbind(xy1, xy2[-1,])
  }
  #
  # Pre-process the input so that sorting is done once
  # and the most detail is extracted from the data.
  #
  is.reversed <- length(y0) < length(x0)
  if (use.shortest) is.reversed <- !is.reversed
  if (is.reversed) {
    y <- sort(x0)
    n <- length(y)
    x <- quantile(y0, prob=(1:n-1)/(n-1))    
  } else {
    y <- sort(y0)
    n <- length(y)
    x <- quantile(x0, prob=(1:n-1)/(n-1))    
  }
  #
  # Convert the relative threshold t.y into an absolute.
  #
  thresh <- t.y * diff(range(y))
  #
  # Recursively obtain points on the QQ plot.
  #
  xy <- qq.int(x, y, 1, n)
  if (is.reversed) cbind(x=xy[,2], y=xy[,1], i=xy[,3]) else xy
}

举例来说，我使用的模拟数据与我之前的答案相同（这次y有异常高的异常值加入，x这次污染很多）：

set.seed(17)
n.x <- 1.21 * 10^6
n.y <- 1.20 * 10^6
k <- floor(0.01*n.x)
x <- c(rnorm(n.x-k), rnorm(k, mean=2, sd=2))
x <- x[x <= -3 | x >= -2.5]
y <- c(rbeta(n.y, 10,13), 1)

让我们使用阈值的值越来越小来绘制几个版本。如果值为.0005，并且在监视器上显示1000像素高，我们将保证误差不大于图形上所有垂直像素的一半。以灰色显示（仅522点，由线段连接）；粗略的近似值绘制在其顶部：首先是黑色，然后是红色（红色点将是黑色部分的子集并对其进行过度绘制），然后是蓝色（再次是子集和过度绘制）。时间范围从6.5（蓝色）到10秒（灰色）。鉴于它们的缩放比例如此之好，人们不妨将大约一半的像素用作阈值的通用默认值（例如，对于1000像素高的监视器为1/2000），并以此完成操作。

qq.1 <- qq(x,y)
plot(qq.1, type="l", lwd=1, col="Gray",
     xlab="x", ylab="y", main="Adaptive QQ Plot")
points(qq.1, pch=".", cex=6, col="Gray")
points(qq(x,y, .01), pch=23, col="Black")
points(qq(x,y, .03), pch=22, col="Red")
points(qq(x,y, .1), pch=19, col="Blue")

编辑

我已经修改了原始代码，qq以将第三列索引返回到原始两个数组中最长（或指定的最短）的位置，x并且y与选定的点相对应。这些索引指向数据的“有趣”值，因此对于进一步分析很有用。

我还删除了重复值x（导致beta未定义）引起的错误。

删除中间的一些数据点将更改经验分布，从而更改qqplot。话虽如此，您可以执行以下操作并直接绘制经验分布的分位数与理论分布的分位数：

x <- rnorm(1200000)
mean.x <- mean(x)
sd.x <- sd(x)
quantiles.x <- quantile(x, probs = seq(0,1,b=0.000001))
quantiles.empirical <- qnorm(seq(0,1,by=0.000001),mean.x,sd.x)
plot(quantiles.x~quantiles.empirical) 

您将不得不根据想要深入尾部的深度来调整音序。如果您想变得聪明，也可以在中间变细该序列以加快绘图速度。例如使用

plogis(seq(-17,17,by=.1))

是可能的。

你可以做个hexbin情节。

x <- rnorm(1200000)
mean.x <- mean(x)
sd.x <- sd(x)
quantiles.x <- quantile(x, probs = seq(0,1,b=0.000001))
quantiles.empirical <- qnorm(seq(0,1,by=0.000001),mean.x,sd.x)

library(hexbin)
bin <- hexbin(quantiles.empirical[-c(1,length(quantiles.empirical))],quantiles.x[-c(1,length(quantiles.x))],xbins=100)
plot(bin)

另一种选择是并行箱线图。您说您有两个数据集，所以类似：

y <- rnorm(1200000)
x <- rnorm(1200000)
grpx <- cut(y,20)
boxplot(y~grpx)

您可以调整各种选项以更好地处理您的数据。