R从数据框中按组别移除离群值(outlier)

Liang / 2018-12-14

离群值(outlier)通常被定义为小于 QL - l.5 IQR 或者大于 Qu + 1.5 IQR的值，QL称为下四分位数， Qu称为上四分位数，IQR称为四分位数间距，是Qu上四分位数和QL下四分位数之差，其间包括了全部观察值的一半。

1.方法一：

定义功能剔除离群值

remove_outliers <- function(x, na.rm = TRUE, ...) {
  qnt <- quantile(x, probs=c(.25, .75), na.rm = na.rm, ...)
  H <- 1.5 * IQR(x, na.rm = na.rm)
  y <- x
  y[x <= (qnt[1] - H)] <- NA
  y[x >= (qnt[2] + H)] <- NA
  y
}

制造数据框

element <- sample(letters[1:5], 1e4, replace=T)
value <- rnorm(1e4)
df <- data.frame(element, value)
head(df)

##   element      value
## 1       b  1.1945698
## 2       b  1.4646831
## 3       c -0.9740408
## 4       d  1.1871266
## 5       a -0.0244541
## 6       d  0.1584528

ggplot(df, aes(x=element, y=value,color=element)) + 
  geom_boxplot(outlier.colour="red", outlier.shape=7,outlier.size=1) + #指出离群值
  theme_bw() + 
  theme(legend.position="right")+
  labs(title="",x="", y = "")

由图可以看出确实有很多离群值

测试下分组剔除离群值

df2 <- df %>%
  group_by(element) %>%
  mutate(value = remove_outliers(value))
head(df2)

## # A tibble: 6 x 2
## # Groups:   element [4]
##   element   value
##   <fct>     <dbl>
## 1 b        1.19  
## 2 b        1.46  
## 3 c       -0.974 
## 4 d        1.19  
## 5 a       -0.0245
## 6 d        0.158

df2 <- na.omit(df2) # 移除NA值

ggplot(df2, aes(x=element, y=value,color=element)) + 
  geom_boxplot(outlier.colour="red", outlier.shape=7,outlier.size=1) + #指出离群值
  theme_bw() + 
  theme(legend.position="right")+
  labs(title="",x="", y = "")

由图可以看出已经移除了大部分的离群值。

2.方法二

element <- sample(letters[1:5], 1e4, replace=T)
value <- rnorm(1e4)
df <- data.frame(element, value)

means.without.ols <- tapply(value, element, function(x) {
  mean(x[!(abs(x - median(x)) > 2*sd(x))])
})

df1 = df %>%
  group_by(element) %>%
  summarise_each(funs(mean), value)

means.without.ols

##             a             b             c             d             e 
##  0.0006870323 -0.0881612981 -0.0523121887 -0.0026486967  0.0108376882

df1

## # A tibble: 5 x 2
##   element    value
##   <fct>      <dbl>
## 1 a        0.0110 
## 2 b       -0.0505 
## 3 c       -0.0432 
## 4 d        0.00230
## 5 e        0.00847

element <- sample(letters[1:5], 1e4, replace=T)
value <- rnorm(1e4)
df <- data.frame(element, value)

means.without.ols <- tapply(value, element, function(x) {
  mean(x[!(abs(x - median(x)) > 2*sd(x))])
})

# df1 = df %>%
#   group_by(element) %>%
#   filter(!(abs(value - median(value)) > 2*sd(value))) %>%
#   summarise_each(funs(mean), value)

means.without.ols

##            a            b            c            d            e 
##  0.016652511 -0.039851375  0.013454980 -0.015648452  0.001179449

最后一次修改于 2018-12-14