快速从 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

您可能还想查看插入符包中的 nearZeroVar() 函数。

如果 1000 个事件中有一个，则丢弃这些数据可能是个好主意（但这取决于模型）。 nearZeroVar() 可以做到这一点。

Answer 2

不要使用 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

但您会必须看看它们的规模是否与实际问题的规模相似。

Answer 3

根本不要使用 table - 它在数字向量上非常慢，因为它将它们转换为字符串。我可能会使用类似的方法，

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

对于 0 方差，为 TRUE；对于具有 NA 的列，使用 NA；对于非零方差，使用 FALSE

Answer 4

使用 Caret 包和函数 nearZeroVar

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

Answer 5

因为我是一个一直在谷歌上搜索同一问题的白痴，所以让我留下一个我已经确定的 tidyverse 方法：

library(tidyverse)

df <- df %>%
  select(
    - {
      df %>%
        map_dbl(~ length(table(.x, useNA = "ifany"))) %>%
        {which(. == 1)} %>%
        names()
    }
  )

我认为这可以缩短，但我太累了！

Answer 6

好吧，为自己节省一些编码时间：

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.ological(bar)] 应该可以解决问题。

Answer 7

如何使用 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 更改此设置> 因子参数：

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 8

我认为零方差相当于恒定，并且无需进行任何算术运算就可以解决问题。我希望 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])
}

Answer 9

检查这个自定义功能。我没有在具有 100 多个变量的数据帧上尝试它。

remove_low_variance_cols <- function(df, threshold = 0) {
  n <- Sys.time() #See how long this takes to run
  remove_cols <- df %>%
    select_if(is.numeric) %>%
    map_dfr(var) %>%
    gather() %>% 
    filter(value <= threshold) %>%
    spread(key, value) %>%
    names()

  if(length(remove_cols)) {
    print("Removing the following columns: ")
    print(remove_cols)
  }else {
    print("There are no low variance columns with this threshold")
  }
  #How long did this script take?
  print(paste("Time Consumed: ", Sys.time() - n, "Secs."))
  return(df[, setdiff(names(df), remove_cols)])
}