Rimozione di punti estranei vicino al centro di un diagramma QQ

Sto cercando di tracciare un diagramma QQ con due set di dati di circa 1,2 milioni di punti, in R (usando qqplot e inserendo i dati in ggplot2). Il calcolo è abbastanza semplice, ma il grafico risultante è dolorosamente lento da caricare, perché ci sono così tanti punti. Ho provato l'approssimazione lineare per ridurre il numero di punti a 10000 (questo è ciò che fa comunque la funzione qqplot, se uno dei tuoi set di dati è più grande dell'altro), ma poi perdi molti dettagli nelle code.

La maggior parte dei punti dati verso il centro sono sostanzialmente inutili: si sovrappongono così tanto che probabilmente ci sono circa 100 per pixel. Esiste un modo semplice per rimuovere i dati troppo vicini tra loro, senza perdere i dati più radi verso le code?

I grafici QQ sono incredibilmente autocorrelati, tranne nelle code. Nel rivederli, ci si concentra sulla forma generale della trama e sul comportamento della coda. Ergo , farai benissimo sottocampionando grossolanamente nei centri delle distribuzioni e includendo una quantità sufficiente di code.

Ecco il codice che illustra come campionare un intero set di dati e come prendere valori estremi.

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
}

Per illustrare, questo set di dati simulato mostra una differenza strutturale tra due set di dati di circa 1,2 milioni di valori e una quantità molto piccola di "contaminazione" in uno di essi. Inoltre, per rendere questo test rigoroso, un intervallo di valori viene escluso del tutto da uno dei set di dati: il diagramma QQ deve mostrare un'interruzione per tali valori.

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)

Possiamo sottocampionare lo 0,1% di ogni set di dati e includere un altro 0,1% dei loro estremi, dando 2420 punti per la trama. Il tempo totale trascorso è inferiore a 0,5 secondi:

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

Nessuna informazione è persa di sorta:

Altrove in questo thread ho proposto un semplice ma in qualche modo ad hoc per sottocampionare i punti. È veloce, ma richiede un po 'di sperimentazione per produrre grandi trame. La soluzione che sta per essere descritta è un ordine di grandezza più lento (impiega fino a 10 secondi per 1,2 milioni di punti) ma è adattivo e automatico. Per set di dati di grandi dimensioni, dovrebbe dare buoni risultati la prima volta e farlo ragionevolmente rapidamente.

$D_n$ , la massima deviazione verticale da una linea adattata. Di conseguenza, l'algoritmo è questo:

$(x,y)$$t$$y$ , sostituisci il grafico con questa linea. Altrimenti, suddividere i dati in quelli che precedono il punto di massima deviazione verticale e in quelli successivi e applicare ricorsivamente l'algoritmo ai due pezzi.

Ci sono alcuni dettagli di cui occuparsi, in particolare per far fronte a set di dati di diversa lunghezza. Lo faccio sostituendo quello più corto con i quantili corrispondenti a quello più lungo: in effetti, al posto dei valori dei dati effettivi viene utilizzata un'approssimazione lineare a tratti dell'EDF di quello più corto. ("Più breve" e "più lungo" possono essere invertiti impostando use.shortest=TRUE.)

Ecco Run'implementazione.

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
}

Ad esempio, utilizzo i dati simulati come nella mia precedente risposta (con un outlier estremamente elevato lanciato ye un po 'più di contaminazione in xquesto momento):

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)

Tracciamo diverse versioni, usando valori sempre più piccoli della soglia. Con un valore di .0005 e la visualizzazione su un monitor di 1000 pixel di altezza, garantiremmo un errore non superiore alla metà di un pixel verticale ovunque sulla trama. Questo è mostrato in grigio (solo 522 punti, uniti da segmenti di linea); le approssimazioni più grossolane sono tracciate sopra di essa: prima in nero, poi in rosso (i punti rossi saranno un sottoinsieme di quelli neri e li sovrapporranno), quindi in blu (che di nuovo sono un sottoinsieme e un overplot). I tempi vanno da 6,5 ​​(blu) a 10 secondi (grigio). Dato che si ridimensionano così bene, si potrebbe anche usare circa mezzo pixel come valore predefinito universale per la soglia ( ad esempio , 1/2000 per un monitor alto 1000 pixel) e farlo con esso.

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

modificare

Ho modificato il codice originale per qqrestituire una terza colonna di indici nel più lungo (o più breve, come specificato) dei due array originali xe y, corrispondente ai punti selezionati. Questi indici indicano valori "interessanti" dei dati e quindi potrebbero essere utili per ulteriori analisi.

Ho anche rimosso un bug che si verificava con valori ripetuti di x(che risultava betaessere indefinito).

La rimozione di alcuni dei punti dati nel mezzo cambierebbe la distribuzione empirica e quindi il qqplot. Detto questo, puoi fare quanto segue e tracciare direttamente i quantili della distribuzione empirica rispetto ai quantili della distribuzione teorica:

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) 

Dovrai regolare il seq in base alla profondità con cui vuoi entrare nelle code. Se vuoi diventare intelligente puoi anche assottigliare quella sequenza nel mezzo per accelerare la trama. Ad esempio usando

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

è una possibilità.

Potresti fare una hexbintrama.

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)

Un'altra alternativa è un boxplot parallelo; hai detto di avere due set di dati, quindi qualcosa del tipo:

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

e puoi adattare le varie opzioni per renderlo migliore con i tuoi dati.