Eliminar valores atípicos del cálculo del coeficiente de correlación

Question

Supongamos que tenemos dos vectores numéricos x y y. El coeficiente de correlación de Pearson entre x y y está dada por

cor (x, y)

¿Cómo puedo considerar de forma automática sólo un subconjunto de x y y en el cálculo (por ejemplo 90%) como para maximizar el coeficiente de correlación?

Answer 1

Si realmente quiere hacer esto (eliminar los residuos más grandes (absolutos)), entonces podemos emplear el modelo lineal para estimar la menor solución de cuadrados y residuales asociados y luego seleccionar el n% medio de los datos. He aquí un ejemplo:

En primer lugar, generar algunos datos ficticios:

require(MASS) ## for mvrnorm() 
set.seed(1) 
dat <- mvrnorm(1000, mu = c(4,5), Sigma = matrix(c(1,0.8,1,0.8), ncol = 2)) 
dat <- data.frame(dat) 
names(dat) <- c("X","Y") 
plot(dat) 

A continuación, se ajusta al modelo lineal y extraer los residuos:

res <- resid(mod <- lm(Y ~ X, data = dat)) 

La función quantile() nosotros el requerido puede dar cuantiles de los residuales. Usted sugirió retener el 90% de los datos, por lo que queremos que el superior e inferior de 0,05 cuantiles:

res.qt <- quantile(res, probs = c(0.05,0.95)) 

Seleccionar esas observaciones con los residuos en el medio del 90% de los datos:

want <- which(res >= res.qt[1] & res <= res.qt[2]) 

Podemos entonces visualizar esto, con los puntos rojos que son los que vamos a retener:

plot(dat, type = "n") 
points(dat[-want,], col = "black", pch = 21, bg = "black", cex = 0.8) 
points(dat[want,], col = "red", pch = 21, bg = "red", cex = 0.8) 
abline(mod, col = "blue", lwd = 2) 

Las correlaciones para los datos completos y el subconjunto seleccionado son:

> cor(dat) 
      X   Y 
X 1.0000000 0.8935235 
Y 0.8935235 1.0000000 
> cor(dat[want,]) 
      X   Y 
X 1.0000000 0.9272109 
Y 0.9272109 1.0000000 
> cor(dat[-want,]) 
     X  Y 
X 1.000000 0.739972 
Y 0.739972 1.000000 

Tenga en cuenta que aquí podríamos estar tirar perfectamente buenos datos, porque simplemente selecciona el 5% con mayores residuos positivos y 5% con el mayor negativo Una alternativa es seleccionar el 90% con más pequeños absolutos residuos:

ares <- abs(res) 
absres.qt <- quantile(ares, prob = c(.9)) 
abswant <- which(ares <= absres.qt) 
## plot - virtually the same, but not quite 
plot(dat, type = "n") 
points(dat[-abswant,], col = "black", pch = 21, bg = "black", cex = 0.8) 
points(dat[abswant,], col = "red", pch = 21, bg = "red", cex = 0.8) 
abline(mod, col = "blue", lwd = 2) 

Con esta ligeramente diferente subconjunto, la correlación es ligeramente inferior:

> cor(dat[abswant,]) 
      X   Y 
X 1.0000000 0.9272032 
Y 0.9272032 1.0000000 

Otro punto es que incluso entonces estamos tirando sacar buenos datos. Es posible que desee ver la distancia de Cook como una medida de la fuerza de los valores atípicos, y descartar solo los valores por encima de un cierto umbral de distancia de Cook.Wikipedia tiene información sobre la distancia de Cook y los umbrales propuestos. La función cooks.distance() se puede utilizar para recuperar los valores de mod:

> head(cooks.distance(mod)) 
      1   2   3   4   5   6 
7.738789e-04 6.056810e-04 6.375505e-04 4.338566e-04 1.163721e-05 1.740565e-03 

y si usted calcula el umbral (s) sugirió en Wikipedia y eliminar sólo aquellos que superan el umbral. Para estos datos:

> any(cooks.distance(mod) > 1) 
[1] FALSE 
> any(cooks.distance(mod) > (4 * nrow(dat))) 
[1] FALSE 

ninguna de las distancias de Cook inferior a los límites propuestos (. No es sorprendente dada la forma en que generan los datos)

Habiendo dicho todo esto, ¿por qué quieres hacer esto? Si solo estás tratando de deshacerte de los datos para mejorar una correlación o generar una relación significativa, eso suena un poco sospechoso y un poco como el dragado de datos para mí.

Answer 2

Usted puede tratar de bootstrapping los datos para encontrar el coeficiente de correlación más alta, por ejemplo .:

x <- cars$dist 
y <- cars$speed 
percent <- 0.9   # given in the question above 
n <- 1000    # number of resampling 
boot.cor <- replicate(n, {tmp <- sample(round(length(x)*percent), replace=FALSE); cor(x[tmp], y[tmp])}) 

Y después de carrera max(boot.cor). No será decepcionado si todos los coeficientes de correlación serán todos iguales :)

Answer 3

Esto puede haber sido ya obvio para el OP, pero solo para asegurarse ... Debe tener cuidado porque tratar de maximizar la correlación puede tender a incluir valores atípicos. (@Gavin tocó este punto en sus respuestas/comentarios.) Sería primero eliminando valores atípicos, luego calculando una correlación. En términos más generales, queremos calcular una correlación robusta a valores atípicos (y hay muchos métodos similares en R).

Sólo para ilustrar esta manera espectacular, vamos a crear dos vectores x y y que no están correlacionados:

set.seed(1) 
x <- rnorm(1000) 
y <- rnorm(1000) 
> cor(x,y) 
[1] 0.006401211 

Ahora vamos a añadir un punto atípico (500,500):

x <- c(x, 500) 
y <- c(y, 500) 

Ahora la correlación de cualquier El subconjunto que incluye el punto atípico estará cerca del 100% y la correlación de cualquier subconjunto suficientemente grande que excluya el valor atípico será cerca de cero. En particular,

> cor(x,y) 
[1] 0.995741 

Si desea estimar un "verdadero" de correlación que no es sensible a los valores atípicos, es posible que trate el robust paquete:

require(robust) 
> covRob(cbind(x,y), corr = TRUE) 
Call: 
covRob(data = cbind(x, y), corr = TRUE) 

Robust Estimate of Correlation: 
      x   y 
x 1.00000000 -0.02594260 
y -0.02594260 1.00000000 

se puede jugar con los parámetros de covRob a decidir cómo recortar los datos. ACTUALIZACIÓN: También está el rlm (regresión lineal robusta) en el paquete MASS.

Answer 4

usando method = "spearman" en cor habrá robusta a la contaminación y es fácil de implementar, ya que sólo implica la sustitución de cor(x, y) con cor(x, y, method = "spearman").

Repitiendo el análisis de Prasad, pero utilizando correlación de Spearman lugar nos encontramos con que la correlación de Spearman es de hecho robustos a la contaminación aquí, la recuperación de la correlación que subyace a cero:

set.seed(1) 

# x and y are uncorrelated 
x <- rnorm(1000) 
y <- rnorm(1000) 
cor(x,y) 
## [1] 0.006401211 

# add contamination -- now cor says they are highly correlated 
x <- c(x, 500) 
y <- c(y, 500) 
cor(x, y) 
## [1] 0.995741 

# but with method = "spearman" contamination is removed & they are shown to be uncorrelated 
cor(x, y, method = "spearman") 
## [1] -0.007270813 

Answer 5

Aquí otra posibilidad con los valores atípicos capturados.El uso de un esquema similar al Prasad:

library(mvoutlier)  
set.seed(1)  
x <- rnorm(1000)  
y <- rnorm(1000)  
xy <- cbind(x, y)  
outliers <- aq.plot(xy, alpha=0.975) #The documentation/default says alpha=0.025. I think the functions wants 0.975 
cor.plot(x, y)  
color.plot(xy) 
dd.plot(xy) 
uni.plot(xy)  

En las otras respuestas, 500 fue atrapado en el extremo de X e Y como un valor atípico. Eso puede, o no, causar un problema de memoria con su máquina, así que lo dejé caer a 4 para evitar eso.

x1 <- c(x, 4)  
y1 <- c(y, 4)  
xy1 <- cbind(x1, y1)  
outliers1 <- aq.plot(xy1, alpha=0.975) #The documentation/default says alpha=0.025. I think the functions wants 0.975 
cor.plot(x1, y1)  
color.plot(xy1)  
dd.plot(xy1)  
uni.plot(xy1)  

Estas son las imágenes de la x1, y1, los datos xy1: