按行查找最频繁的值

Question

我的问题如下：

我有一个包含多个因子变量的数据集，这些变量具有相同的类别。我需要找到每一行中出现最频繁的类别。如果存在并列情况，则可以选择任意值，但如果我能有更多控制权就更好了。

我的数据集包含超过一百个因子，但结构大致如下：

df = data.frame(id = 1:3
                var1 = c("red","yellow","green")
                var2 = c("red","yellow","green")
                var3 = c("yellow","orange","green")
                var4 = c("orange","green","yellow"))

df
#   id   var1   var2   var3   var4
# 1  1    red    red yellow orange
# 2  2 yellow yellow orange  green
# 3  3  green  green  green yellow

解决方案应该是数据框中的一个变量，例如var5，它包含每行最常见的类别。它可以是一个因子或一个数值向量（如果需要将数据先转换为数值向量）。

在这种情况下，我想要这个解决方案：

df$var5
# [1] "red"    "yellow" "green" 

任何建议都将不胜感激！提前致谢！

- ZMacarozzi

Answer 1

类似这样：

apply(df,1,function(x) names(which.max(table(x))))
[1] "red"    "yellow" "green" 

如果存在并列的情况，which.max将选取第一个最大值。从which.max帮助页面得知：

确定数值向量中（第一个）最小或最大值的位置，即索引。

例如：

var4 <- c("yellow","green","yellow")
df <- data.frame(cbind(id, var1, var2, var3, var4))

> df
  id   var1   var2   var3   var4
1  1    red    red yellow yellow
2  2 yellow yellow orange  green
3  3  green  green  green yellow

apply(df,1,function(x) names(which.max(table(x))))
[1] "red"    "yellow" "green" 

- Chargaff

---

干得好，比我的代码整洁。我没有意识到可以跳过所有的转换、去除列表等步骤。 - Ben Bolker

非常感谢您提供的解决方案。我已经在自己的数据上尝试过，它完美地运行了！请问一下，这种方法是如何解决并列的情况的呢？谢谢！ - ZMacarozzi

我编辑了我的答案，以说明平局的情况。学习如何使用帮助页面是一个好习惯。很高兴我的解决方案对你有用。 - Chargaff

非常感谢你 - 我真的很感激。是的，我同意您关于帮助页面的价值观 - 下次我会确保查看帮助页面。 - ZMacarozzi

Answer 2

如果您的数据非常大，您可能希望考虑使用 data.table 软件包。

# Generate the data
nrow <- 10^5
id <- 1:nrow
colors <- c("red","yellow","green")
var1 <- sample(colors, nrow, replace = TRUE)
var2 <- sample(colors, nrow, replace = TRUE)
var3 <- sample(colors, nrow, replace = TRUE)
var4 <- sample(colors, nrow, replace = TRUE)

Mode <- function(x) {
    ux <- unique(x)
    ux[which.max(tabulate(match(x, ux)))]
}

查戈夫的解决方案很简单，对于某些情况效果很好。您可以通过使用data.table获得小幅性能提升（约20％）。

df <- data.frame(cbind(id, var1, var2, var3, var4))
system.time(apply(df, 1, Mode))
#   user  system elapsed
#  1.242   0.018   1.264

library(data.table)
dt <- data.table(cbind(id, var1, var2, var3, var4))
system.time(melt(dt, measure = patterns('var'))[, Mode(value1), by = id])
#   user  system elapsed
#  1.020   0.012   1.034

- janosdivenyi

---

请注意，如果NA是最常见的元素，则此Mode函数将返回NA，而names(which.max(table(x)))将返回最常见的非NA元素。 - IceCreamToucan

Answer 3

我为一个内部包制作了一个rowMode函数，您可以选择如何处理并列和缺失值：

rowMode <- function(x, ties = NULL, include.na = FALSE) {
  # input checks data
  if ( !(is.matrix(x) | is.data.frame(x)) ) {
    stop("Your data is not a matrix or a data.frame.")
  }
  # input checks ties method
  if ( !is.null(ties) && !(ties %in% c("random", "first", "last")) ) {
    stop("Your ties method is not one of 'random', 'first' or 'last'.")
  }
  # set ties method to 'random' if not specified
  if ( is.null(ties) ) ties <- "random"
  
  # create row frequency table
  rft <- table(c(row(x)), unlist(x), useNA = c("no","ifany")[1L + include.na])
  
  # get the mode for each row
  colnames(rft)[max.col(rft, ties.method = ties)]
}

根据不同的参数选项，可能会有几个不同的输出：

> rowMode(DF[,-1])
 [1] "B" "E" "B" "E" "B" "C" "B" "E" "A" "E"
> rowMode(DF[,-1], ties = "first")
 [1] "B" "B" "B" "A" "B" "C" "B" "E" "A" "E"
> rowMode(DF[,-1], ties = "first", include.na = TRUE)
 [1] "B" NA  "B" NA  "B" "C" "B" "E" "A" "E"
> rowMode(DF[,-1], ties = "last", include.na = TRUE)
 [1] "B" NA  NA  NA  "B" "C" "B" "E" "D" "E"
> rowMode(DF[,-1], ties = "last")
 [1] "B" "C" "B" "E" "B" "C" "B" "E" "D" "E"

---

使用的数据：

set.seed(2020)
DF <- data.frame(id = 1:10, matrix(sample(c(LETTERS[1:5], NA_character_), 60, TRUE), ncol = 6))

- Jaap

Answer 4

这里是另一个基于R语言的选项：

tab <- table(data.frame(as.vector(row(df[,-1L])), unlist(df[,-1L])))
colnames(tab)[max.col(tab, "first")]

或者另一种 data.table 的方法：

melt(as.data.table(df), id.vars="id")[
    order(id, value), ri := rowid(rleid(value))][,
        value[which.max(ri)], id]$V1

计时代码：

library(data.table)
set.seed(0L)
nr <- 1e5L
nc <- 4L
DF <- data.frame(id=1L:nr, as.data.frame(matrix(sample(letters, nr*nc, TRUE), ncol=nc)))
DT <- as.data.table(DF)

mtd0 <- function(df) apply(df,1,function(x) names(which.max(table(x))))

Mode <- function(x) {
    ux <- unique(x)
    ux[which.max(tabulate(match(x, ux)))]
}

mtd_dt <- function(dt) melt(dt, id.vars="id")[, Mode(value), id]$V1

mtd_dt2 <- function(dt) melt(dt, id.vars="id")[
    order(id, value), ri := rowid(rleid(value))][,
        value[which.max(ri)], id]$V1

mtd2 <- function(df) {
    tab <- table(data.frame(as.vector(row(df[,-1L])), unlist(df[,-1L])))
    colnames(tab)[max.col(tab, "first")]
}

df = data.frame(id = 1:3,
    var1 = c("red","yellow","green"),
    var2 = c("red","yellow","green"),
    var3 = c("yellow","orange","green"),
    var4 = c("orange","green","yellow"))

a0 <- mtd0(df)
identical(a0, mtd_dt(as.data.table(df)))
#[1] TRUE

identical(a0, mtd2(df))
#[1] TRUE

identical(a0, mtd_dt2(as.data.table(df)))
#[1] TRUE

microbenchmark::microbenchmark(times=1L, mtd0(DF), mtd_dt(DT), mtd_dt2(DT), mtd2(DF))

时间：

Unit: milliseconds
        expr        min         lq       mean     median         uq        max neval
    mtd0(DF) 10083.9941 10083.9941 10083.9941 10083.9941 10083.9941 10083.9941     1
  mtd_dt(DT)  1056.2319  1056.2319  1056.2319  1056.2319  1056.2319  1056.2319     1
 mtd_dt2(DT)   168.6183   168.6183   168.6183   168.6183   168.6183   168.6183     1
    mtd2(DF)   519.2030   519.2030   519.2030   519.2030   519.2030   519.2030     1

- chinsoon12