QQ 플롯 중심 근처의 불필요한 점 제거

R에서 약 120 만 포인트의 두 데이터 세트로 QQ 플롯을 플로팅하려고합니다 (qqplot 사용 및 ggplot2에 데이터 공급). 계산은 쉽지만 결과 그래프는로드가 너무 느립니다. 점이 너무 많기 때문입니다. 점 수를 10000으로 줄이기 위해 선형 근사법을 시도했지만 (데이터 세트 중 하나가 다른 것보다 큰 경우 qqplot 함수가 수행하는 작업입니다) 꼬리의 세부 사항을 많이 잃습니다.

중심을 향한 대부분의 데이터 포인트는 기본적으로 쓸모가 없습니다. 픽셀 당 약 100 개가 될 정도로 겹칩니다. 꼬리를 향해 더 희소 한 데이터를 잃지 않고 너무 가까운 데이터를 제거하는 간단한 방법이 있습니까?

QQ 플롯은 꼬리를 제외하고 는 매우 자기 상관 관계가 있습니다. 그것들을 검토 할 때, 플롯의 전반적인 모양과 꼬리 행동에 중점을 둡니다. Ergo , 당신은 거칠게 잘 할 것입니다 분포의 중심에서 서브 샘플링하고 충분한 양의 꼬리를 포함하여 입니다.

다음은 전체 데이터 집합에서 샘플링하는 방법과 극단적 인 값을 얻는 방법을 보여주는 코드입니다.

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

어떠한 정보도 손실되지 않습니다 :

이 스레드의 다른 곳에서 포인트를 서브 샘플링 하는 간단하지만 다소 임시적인 솔루션을 제안했습니다 . 빠르지 만 훌륭한 음모를 만들려면 약간의 실험이 필요합니다. 설명 될 해결책은 10 배 더 느리지 만 (120 만 포인트 동안 최대 10 초 소요) 적응 적이고 자동적입니다. 대규모 데이터 세트의 경우 처음에는 좋은 결과를 제공하고 합리적으로 신속하게 수행해야합니다.

아이디어는 Douglas-Peucker 의 아이디어입니다. $D_n$

의 극값을 연결하는 선 사이의 최대 수직 편차를 찾습니다$(x,y)$$t$$y$

특히 길이가 다른 데이터 세트에 대처하기 위해 처리해야 할 세부 사항이 있습니다. 나는 더 짧은 것을 더 긴 것에 대응하는 Quantile로 대체함으로써 이것을한다 : 사실상, 더 짧은 것의 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)과 마찬가지로 약 1/2 픽셀을 사용할 수 있습니다.

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이 변경됩니다. 이것은 다음을 수행하고 경험적 분포의 Quantile과 이론적 분포의 Quantile을 직접 플로팅 할 수 있습니다.

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)

또 다른 대안은 평행 박스 플롯입니다. 두 개의 데이터 세트가 있다고 말 했으므로 다음과 같습니다.

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

다양한 옵션을 조정하여 데이터를 개선 할 수 있습니다.