快速从数据框中删除方差为零的变量

Question

我有一个大的数据框，它是由我不能控制的过程生成的，其中可能包含具有零方差的变量（即所有观测值都相同）。我想基于这个数据构建一个预测模型，显然这些变量没有用处。

这是我目前正在使用的函数，用于从数据框中删除这样的变量。它目前基于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

- Zach

Answer 1

您可能还需要查看 caret 包中的 nearZeroVar() 函数。如果您的数据集中有 1000 个事件中的一个事件，则舍弃这些数据可能是一个好主意（但这取决于模型）。nearZeroVar() 可以实现这一点。

- topepo

---

谢谢您的建议，我实际上一直在使用 nearZeroVar()，而这个问题就是基于该函数的。有时候我发现自己只想删除方差为零的变量，并以另一种方式处理“接近零方差”的变量（例如，将几个“接近零方差”变量合并成一个新变量）。 - Zach

我刚试过了这种方法。当你使用nearZeroVar()函数时，设定 saveMetrics = T，那么输出便会同时显示zeroVar(方差为0)和nzv(接近0的方差)。通过在函数中设定其他阈值，你可以自由选择接近0方差的不同值所占比例的截断点。所以，我认为这种方法更简单灵活。 - Cherry Wu

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

但您需要查看它们是否与实际问题大小相似。

- Gavin Simpson

---

正如我在我的（较弱的）解决方案中所指出的，除非你确定x是所有整数，否则要小心使用length(unique(x))。 - Carl Witthoft

您IP地址为143.198.54.68，由于运营成本限制，当前对于免费用户的使用频率限制为每个IP每72小时10次对话，如需解除限制，请点击左下角设置图标按钮（手机用户先点击左上角菜单按钮）。 - puslet88

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。

- Simon Urbanek

---

将所有值为NA的列转换为TRUE，将包含NA和其他值的列转换为FALSE，这个任务难度如何？ - Zach

不错。在这里或更一般的情况下，有没有理由更喜欢使用 unlist（lapply（...）） 而不是 sapply（...）？ - Josh O'Brien

好的，“sapply”调用“lapply”，然后在结果上进行一些处理，最后调用“unlist”，因此我喜欢使用更原始的函数，这样我就知道它们的作用-这只是我的个人偏好（有时更有效率）。 - Simon Urbanek

很简单 - 只需像在 table 中一样将 na.rm 传递给 var：var0 <- function(df, na.rm=FALSE) unlist(lapply(df, function(x) 0 == var(if (is.factor(x)) as.integer(x) else x, na.rm=na.rm))) - Simon Urbanek

Answer 4

使用Caret包和函数nearZeroVar。

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

- Luigi Biagini

Answer 5

因为我是个傻瓜，总是在谷歌同一个问题，所以让我分享一下我采取的tidyverse方法：

library(tidyverse)

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

我认为这段内容可以更简短，但是我太累了！

- Kim

---

df %>% select(where(function(x) var(x) != 0))怎么样？ - tauft

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.logical(bar)] 处理数据框即可。

- Carl Witthoft

---

Carl - 用发布的数据框试试吧 - 由于因素，你会得到NA ;) - Simon Urbanek

@Simon - 是的，我知道... 我跳过了清理和/或验证源数据的步骤。我承认我有点懒。 - Carl Witthoft

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

默认情况下，NAs将被排除在外，但可以使用factor的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

- James

Answer 8

请检查这个自定义函数。我没有在具有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)])
}

- Muhammad Elkharashy

Answer 9

我认为零方差等同于恒定值，并且可以在根本不进行任何算术运算的情况下解决问题。我希望 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])
}

- Rolf L