Eliminación de valores atípicos basada en la distancia de Cook en R Language

Question

Tengo este código R para la regresión lineal:

fit <- lm(target ~ age+sales+income, data = new)

¿Cómo identificar observaciones influyentes basándose en la distancia de Cook y eliminarlas de los datos en R?

Answer 1

Este post tiene alrededor de 6000 visitas en 2 años así que supongo que una respuesta es muy necesaria. Aunque tomé prestadas muchas ideas de la referencia, hice algunas modificaciones. Vamos a utilizar el cars datos en base r .

library(tidyverse)

# Inject outliers into data.
cars1 <- cars[1:30, ]  # original data
cars_outliers <- data.frame(speed=c(1,19), dist=c(198,199))  # introduce outliers.
cars2 <- rbind(cars1, cars_outliers)  # data with outliers.

Grafiquemos los datos con valores atípicos para ver lo extremos que son.

# Plot of data with outliers.

plot1 <- ggplot(data = cars1, aes(x = speed, y = dist)) +
        geom_point() + 
        geom_smooth(method = lm) +
        xlim(0, 20) + ylim(0, 220) + 
        ggtitle("No Outliers")
plot2 <- ggplot(data = cars2, aes(x = speed, y = dist)) +
        geom_point() + 
        geom_smooth(method = lm) +
        xlim(0, 20) + ylim(0, 220) + 
        ggtitle("With Outliers")

gridExtra::grid.arrange(plot1, plot2, ncol=2)

Podemos ver que la línea de regresión tiene un mal ajuste después de introducir los valores atípicos. Por lo tanto, vamos a utilizar la Distancia de Cook para identificarlos. Utilizo el corte tradicional de $\frac{4}{n}$ . Observe que valor de corte sólo ayuda a pensar en lo que está mal con los datos .

mod <- lm(dist ~ speed, data = cars2)
cooksd <- cooks.distance(mod)

# Plot the Cook's Distance using the traditional 4/n criterion
sample_size <- nrow(cars2)
plot(cooksd, pch="*", cex=2, main="Influential Obs by Cooks distance")  # plot cook's distance
abline(h = 4/sample_size, col="red")  # add cutoff line
text(x=1:length(cooksd)+1, y=cooksd, labels=ifelse(cooksd>4/sample_size, names(cooksd),""), col="red")  # add labels

Hay muchas formas de tratar los valores atípicos, como se indica en la Referencia. Ahora, sólo quiero simplemente eliminarlos.

# Removing Outliers
# influential row numbers
influential <- as.numeric(names(cooksd)[(cooksd > (4/sample_size))])

# Alternatively, you can try to remove the top x outliers to have a look
# top_x_outlier <- 2
# influential <- as.numeric(names(sort(cooksd, decreasing = TRUE)[1:top_x_outlier]))

cars2_screen <- cars2[-influential, ]

plot3 <- ggplot(data = cars2, aes(x = speed, y = dist)) +
        geom_point() + 
        geom_smooth(method = lm) +
        xlim(0, 20) + ylim(0, 220) + 
        ggtitle("Before")
plot4 <- ggplot(data = cars2_screen, aes(x = speed, y = dist)) +
        geom_point() + 
        geom_smooth(method = lm) +
        xlim(0, 20) + ylim(0, 220) + 
        ggtitle("After")

gridExtra::grid.arrange(plot3, plot4, ncol=2)

Hurra, hemos eliminado con éxito los valores atípicos~

Excelente referencia: Tratamiento de valores atípicos