Ще в цій темі я запропонував просте, але дещо спеціальне рішення про підгрупування точок. Це швидко, але вимагає певних експериментів, щоб створити чудові сюжети. Рішення, яке планується описати, - на порядок повільніше (займає до 10 секунд за 1,2 мільйона балів), але є адаптивним та автоматичним. Для великих наборів даних це повинно дати хороші результати в перший раз і зробити це досить швидко.
Dн
( х , у)ту
Є кілька деталей, про які слід подбати, особливо, щоб впоратися з наборами даних різної довжини. Я роблю це, замінюючи коротший на квантові, що відповідають довшому: фактично використовується кусочно лінійне наближення ЕРФ більш короткого, а не його фактичні значення даних. ("Коротше" та "довше" можна змінити налаштування 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 секунд (сірий). Зважаючи на те, що вони масштабують так добре, можна також добре використовувати близько половини пікселів як універсальний за замовчуванням поріг ( наприклад , 1/2000 для високого монітора 1000 пікселів) і робити це з ним.
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невизначеними).
approx()функція вступає в груqqplot().