QQプロットの中心付近の無関係な点を削除する

Rで約120万ポイントの2つのデータセットを使用してQQプロットをプロットしようとしています（qqplotを使用し、データをggplot2に送ります）。計算は簡単ですが、結果のグラフは非常に多くのポイントがあるため、読み込みが非常に遅くなります。ポイント数を10000に減らすために線形近似を試みました（これは、データセットの1つが他のデータセットよりも大きい場合、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万の値を持つ2つのデータセット間の構造的な違いと、その1つにおけるごくわずかな「汚染」を示しています。また、このテストを厳格にするために、値の間隔がデータセットの1つから完全に除外されます。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（指定され、又は最短の）元の2つの配列の最長にインデックスの第3列を返すし、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) 

テールにどの程度深く入りたいかに応じて、seqを調整する必要があります。賢くしたい場合は、途中でそのシーケンスを細くしてプロットを高速化することもできます。たとえば

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)

別の選択肢は、平行箱型図です。2つのデータセットがあると言ったので、次のようになります。

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

さまざまなオプションを調整して、データを改善することができます。