Быстро удалить переменные нулевой дисперсии из data.frame

У меня есть большой data.frame, который был сгенерирован процессом вне моего контроля, который может содержать или не содержать переменные с нулевой дисперсией (т.е. все наблюдения одинаковы). Я хотел бы построить прогностическую модель, основанную на этих данных, и, очевидно, эти переменные бесполезны.

Здесь функция, которую я сейчас использую для удаления таких переменных из data.frame. В настоящее время он основан на apply, и мне было интересно, есть ли какие-либо очевидные способы ускорить эту функцию, чтобы она работала быстро на очень больших наборах данных с большим числом (400 или 500) переменных?

set.seed(1)
dat <- data.frame(
    A=factor(rep("X",10),levels=c('X','Y')),
    B=round(runif(10)*10),
    C=rep(10,10),
    D=c(rep(10,9),1),
    E=factor(rep("A",10)),
    F=factor(rep(c("I","J"),5)),
    G=c(rep(10,9),NA)
)
zeroVar <- function(data, useNA = 'ifany') {
    out <- apply(data, 2, function(x) {length(table(x, useNA = useNA))})
    which(out==1)
}

И вот результат процесса:

> dat
   A B  C  D E F  G
1  X 3 10 10 A I 10
2  X 4 10 10 A J 10
3  X 6 10 10 A I 10
4  X 9 10 10 A J 10
5  X 2 10 10 A I 10
6  X 9 10 10 A J 10
7  X 9 10 10 A I 10
8  X 7 10 10 A J 10
9  X 6 10 10 A I 10
10 X 1 10  1 A J NA

> dat[,-zeroVar(dat)]
   B  D F  G
1  3 10 I 10
2  4 10 J 10
3  6 10 I 10
4  9 10 J 10
5  2 10 I 10
6  9 10 J 10
7  9 10 I 10
8  7 10 J 10
9  6 10 I 10
10 1  1 J NA

> dat[,-zeroVar(dat, useNA = 'no')]
   B  D F
1  3 10 I
2  4 10 J
3  6 10 I
4  9 10 J
5  2 10 I
6  9 10 J
7  9 10 I
8  7 10 J
9  6 10 I
10 1  1 J

Ответы

Ответ 1

Не используйте table() - очень медленно для таких вещей. Один из вариантов: length(unique(x)):

foo <- function(dat) {
    out <- lapply(dat, function(x) length(unique(x)))
    want <- which(!out > 1)
    unlist(want)
}

system.time(replicate(1000, zeroVar(dat)))
system.time(replicate(1000, foo(dat)))

Что на порядок больше, чем у вас, на примере набора данных, давая аналогичный результат:

> system.time(replicate(1000, zeroVar(dat)))
   user  system elapsed 
  3.334   0.000   3.335 
> system.time(replicate(1000, foo(dat)))
   user  system elapsed 
  0.324   0.000   0.324

Решение Simon в этом примере аналогично быстро:

> system.time(replicate(1000, which(!unlist(lapply(dat, 
+             function(x) 0 == var(if (is.factor(x)) as.integer(x) else x))))))
   user  system elapsed 
  0.392   0.000   0.395

но вам нужно будет увидеть, масштабируются ли они аналогично реальным размерам проблем.

Ответ 2

Вы также можете просмотреть функцию nearZeroVar() в пакете каретки.

Если у вас есть одно событие из 1000, может быть хорошей идеей отказаться от этих данных (но это зависит от модели). nearZeroVar() может это сделать.

Ответ 3

Просто не используйте table - он очень медленный для числовых векторов, поскольку он преобразует их в строки. Я бы, вероятно, использовал что-то вроде

var0 <- unlist(lapply(df, function(x) 0 == var(if (is.factor(x)) as.integer(x) else x)))

Это будет TRUE для 0-дисперсии, NA для столбцов с NA и FALSE для ненулевой дисперсии

Ответ 4

Хорошо, спасите себе время кодирования:

Rgames: foo
      [,1]  [,2] [,3]
 [1,]    1 1e+00    1
 [2,]    1 2e+00    1
 [3,]    1 3e+00    1
 [4,]    1 4e+00    1
 [5,]    1 5e+00    1
 [6,]    1 6e+00    2
 [7,]    1 7e+00    3
 [8,]    1 8e+00    1
 [9,]    1 9e+00    1
 [10,]    1 1e+01    1
Rgames: sd(foo)
[1] 0.000000e+00 3.027650e+00 6.749486e-01
Warning message:
sd(<matrix>) is deprecated.
 Use apply(*, 2, sd) instead.

Чтобы избежать неприятных округлений с плавающей запятой, возьмите этот выходной вектор, который я назову "bar", и сделайте что-то вроде bar[bar< 2*.Machine$double.eps] <- 0, а затем, наконец, ваш фрейм данных dat[,as.logical(bar)] должен сделать трюк.

Ответ 5

Как насчет использования factor для подсчета количества уникальных элементов и цикла с помощью sapply:

dat[sapply(dat, function(x) length(levels(factor(x)))>1)]
   B  D F
1  3 10 I
2  4 10 J
3  6 10 I
4  9 10 J
5  2 10 I
6  9 10 J
7  9 10 I
8  7 10 J
9  6 10 I
10 1  1 J

NA исключаются по умолчанию, но это можно изменить с помощью параметра exclude factor:

dat[sapply(dat, function(x) length(levels(factor(x,exclude=NULL)))>1)]
   B  D F  G
1  3 10 I 10
2  4 10 J 10
3  6 10 I 10
4  9 10 J 10
5  2 10 I 10
6  9 10 J 10
7  9 10 I 10
8  7 10 J 10
9  6 10 I 10
10 1  1 J NA

Ответ 6

Используйте Caret Пакет и функцию nearZeroVar

require(caret)
NZV<- nearZeroVar(dataset, saveMetrics = TRUE)
NZV[NZV[,"zeroVar"] > 0, ] 
NZV[NZV[,"zeroVar"] + NZV[,"nzv"] > 0, ]

Ответ 7

Я думаю, что нулевая дисперсия эквивалентна постоянной, и можно обойтись без каких-либо арифметических операций вообще. Я бы ожидал, что range() превосходит var(), но я не подтвердил это:

removeConstantColumns <- function(a_dataframe, verbose=FALSE) {
  notConstant <- function(x) {
    if (is.factor(x)) x <- as.integer(x)
    return (0 != diff(range(x, na.rm=TRUE)))
  }
  bkeep <- sapply(a_dataframe, notConstant)
  if (verbose) {
    cat('removeConstantColumns: '
      , ifelse(all(bkeep)
        , 'nothing'
        , paste(names(a_dataframe)[!bkeep], collapse=',')
      , ' removed',  '\n')
  }
  return (a_dataframe[, bkeep])
}