Как winsorize (или удалить одномерные выбросы) в продольном наборе данных

Я пытаюсь выяснить, как проводить наблюдения, сгруппированные индивидами в продольном наборе данных.

Я начал с этого отличного ответа о том, как удалить данные > 2 стандартных отклонения от среднего значения переменной. Автор также помогает показать, как это сделать в рамках категорий.

Мой вариант использования немного отличается: у меня есть продольный набор данных, и я хочу удалить людей, которые со временем систематически показывают, что это выбросы. Вместо того, чтобы снимать экстремальные наблюдения внутри предметов, я хотел бы либо полностью исключить этих лиц (обрезать данные), либо заменить нижний и верхний 2,5% значением разреза (winsorizing, см. http://en.wikipedia.org/wiki/Winsorising).

Например, мои данные с длинной формой могут выглядеть так:

name time points
MJ   1    998
MJ   2    1000
MJ   3    998
MJ   4    3000
MJ   5    998
MJ   5    420
MJ   6    999
MJ   7    998
Lebron   1    9
Lebron   2    1
Lebron   3    3
Lebron   4    900
Lebron   5    4
Lebron   5    4
Lebron   6    3
Lebron   7    8
Kobe   1    2
Kobe   2    1
Kobe   3    4
Kobe   4    2
Kobe   5    1000
Kobe   5    4
Kobe   6    7
Kobe   7    9
Larry   1    2
Larry   2    1
Larry   3    4
Larry   4    2
Larry   5    800
Larry   5    4
Larry   6    7
Larry   7    9

Если бы я хотел удалить экстремальные наблюдения в points внутри индивидуумов (name), мой код:

do.call(rbind,by(df,df$name,function(x) x[!abs(scale(x$points)) > 2,]))

Но я действительно хочу исключить ИНДИВИДУАЛЬНЫЙ, который является экстремальным (в данном случае MJ). Как мне это сделать?

(P.S.) - вставьте здесь все оговорки о том, как нельзя удалять выбросы. Это просто тест надежности!)

Ответ 1

Я бы просто использовал dplyr:

test <- read.csv("test.csv", header=TRUE)
library(dplyr)

test <- test %.% 
  group_by(name) %.% 
  mutate(mean_points=mean(points))

cut_point_top <- quantile(test$mean_points, 0.95)
cut_point_bottom <- quantile(test$mean_points, 0.05)

test <- test %.% 
  group_by(name) %.% 
  mutate(outlier_top = (mean_points >= cut_point_top), 
         outlier_bottom = mean_points <= cut_point_bottom) %.%
  filter(!outlier_top & ! outlier_bottom)

Это отфильтровывает MJ как средний балл в верхних 2,5%, а Ларри - на 2,5% ниже.

Если вы хотите заменить переменную точек точками отсечения для 2,5 процентов, просто оставьте последний оператор фильтра следующим образом:

test <- test %.% 
  group_by(name) %.% 
  mutate(outlier_top = (mean_points >= cut_point_top), 
         outlier_bottom = mean_points <= cut_point_bottom) 

test$points <- ifelse(test$outlier_top, cut_point_top, 
                      ifelse(test$outlier_bottom, cut_point_bottom, test$points))

Ответ 2

Вот как я могу это сделать:

means <- ddply(df, .(name), summarize, mean=mean(points))$mean
means <- mean(means)

upperBound <- 2

outlierTest <- ddply(df, .(name), summarize, outlier=ifelse(sum(points) / means > upperBound, 
TRUE, FALSE))

keep <- outlierTest$name[!outlierTest$outlier]

df <- df[df$name %in% keep, ]

где df - ваш data.frame. Вы можете выбрать любой upperBound, который вы хотите.

Ответ 3

Возможно, это не подходит для ваших данных, но я собираюсь попытаться создать общее решение, чтобы вы начали думать. Я предлагаю использовать надежную статистику, такую как медианное и медианное абсолютное отклонение (MAD), чтобы определить ваши выбросы. Вы можете начать с рассмотрения доли точек, которые являются выбросами (по сравнению со всеми точками) для каждого человека:

Пусть df будет вашим фреймом данных

library(plyr)

med <- median(df$points)
md <- mad(df$points)
outlier.factor <- 2
daply(df, .(name), function(x) {sum(abs(x$points - m) > md * outlier.factor) / nrow(x)})

Последняя строка выводит следующее (для ваших данных примера):

 Kobe  Larry Lebron     MJ
0.125  0.125  0.125  1.000

Таким образом, все точки для MJ являются выбросами, а 12,5% - выбросами для всех других лиц.

Теперь вы можете использовать пороговое значение для выбора отдельных лиц для удаления. Например, для нормально распределенных данных вы ожидаете, что около 4.55% выйдут за пределы диапазона медианного ± 2 x MAD.