ลบจุดที่ไม่เกี่ยวข้องใกล้กับจุดศูนย์กลางของ QQ-plot

ฉันพยายามพล็อต QQ-plot ด้วยชุดข้อมูลสองชุดประมาณ 1.2 ล้านจุดใน R (ใช้ qqplot และป้อนข้อมูลลงใน ggplot2) การคำนวณนั้นง่ายพอ แต่กราฟผลลัพธ์นั้นโหลดช้าอย่างเจ็บปวดเนื่องจากมีหลายจุด ฉันได้ลองใช้การประมาณเชิงเส้นเพื่อลดจำนวนคะแนนเป็น 10,000 (นี่คือสิ่งที่ฟังก์ชั่น qqplot ทำอยู่แล้วถ้าหนึ่งในชุดข้อมูลของคุณมีขนาดใหญ่กว่าอีกชุดหนึ่ง) แต่คุณสูญเสียรายละเอียดจำนวนมากในหาง

จุดข้อมูลส่วนใหญ่ที่อยู่ตรงกลางนั้นไร้ประโยชน์ - มันซ้อนทับกันมากจนอาจมีประมาณ 100 ต่อพิกเซล มีวิธีง่ายๆในการลบข้อมูลที่อยู่ใกล้กันเกินไปโดยไม่ปล่อยข้อมูลที่กระจัดกระจายไปทางหางหรือไม่?

แปลง QQ มีความสัมพันธ์กันโดยอัตโนมัติอย่างไม่น่าเชื่อยกเว้นในส่วนท้าย ในการตรวจสอบพวกเขามุ่งเน้นไปที่รูปร่างโดยรวมของพล็อตและพฤติกรรมหาง Ergoคุณจะทำอะไรได้ดีโดยหยาบsubsampling ในศูนย์ของการกระจายและรวมถึงจำนวนเงินที่เพียงพอของหาง

นี่คือโค้ดที่แสดงวิธีการสุ่มตัวอย่างในชุดข้อมูลทั้งหมดรวมถึงวิธีการรับค่ามาก ๆ

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
}

เพื่อแสดงให้เห็นว่าชุดข้อมูลจำลองนี้แสดงความแตกต่างทางโครงสร้างระหว่างชุดข้อมูลสองชุดที่มีค่าประมาณ 1.2 ล้านค่าตลอดจน "การปนเปื้อน" จำนวนเล็กน้อยในหนึ่งชุด นอกจากนี้เพื่อให้การทดสอบนี้เข้มงวดช่วงเวลาของค่าจะถูกแยกออกจากหนึ่งในชุดข้อมูลทั้งหมด: พล็อต 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 วินาทีสำหรับ 1.2 ล้านจุด) แต่ปรับได้อัตโนมัติ สำหรับชุดข้อมูลขนาดใหญ่มันควรจะให้ผลลัพธ์ที่ดีในครั้งแรกและทำได้อย่างรวดเร็วพอสมควร

$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 และแสดงบนจอภาพสูง 1,000 พิกเซลเราจะรับประกันข้อผิดพลาดไม่เกินครึ่งพิกเซลแนวตั้งทุกที่บนพล็อต สิ่งนี้แสดงเป็นสีเทา (มีเพียง 522 คะแนนรวมกับส่วนของเส้น) การประมาณค่าที่หยาบจะถูกพล็อตที่ด้านบนของมัน: เป็นครั้งแรกในสีดำ, จากนั้นในสีแดง (จุดสีแดงจะเป็นเซตย่อยของสีดำ ช่วงเวลาตั้งแต่ 6.5 (สีน้ำเงิน) ถึง 10 วินาที (สีเทา) เนื่องจากว่าพวกมันมีอัตราส่วนที่ดีดังนั้นหนึ่งอาจใช้พิกเซลประมาณครึ่งเดียวเป็นค่าเริ่มต้นสากลสำหรับเกณฑ์ ( เช่น 1/2000 สำหรับจอภาพสูง 1,000 พิกเซล) และทำได้ด้วย

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) 

คุณจะต้องปรับ 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)

และคุณสามารถปรับตัวเลือกต่าง ๆ เพื่อให้ดีขึ้นกับข้อมูลของคุณ