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

Question

У меня есть большой 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 

Answer 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 

Саймона здесь так же быстро на этом примере:

> 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 

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

Answer 2

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

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

Это будет TRUE для 0-дисперсии, NA для колонн с НСБУ и FALSE для ненулевой дисперсией

Answer 3

Ну, сэкономить время кодирования:

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< 2*.Machine$double.eps] <- 0, а затем, наконец, ваш кадр данных dat[,as.logical(bar)] shoul сделайте трюк.

Answer 4

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

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

Answer 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 

NAs исключены по умолчанию, но это можно изменить с помощью параметра 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 

Answer 6

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

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]) 
} 

Answer 7

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

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