根据列名中的匹配值和 R 中的特定列创建 0-1 数据框答案

【问题标题】：Create a 0-1 dataframe based on matching values in column names and a specific column in R根据列名中的匹配值和 R 中的特定列创建 0-1 数据框
【发布时间】：2019-04-04 15:33:48
【问题描述】：

我想根据列名的匹配值/类和另一列中给出的信息重新填充数据框。

这是一个假设的数据框：

> mat.data = data.frame(A = c(rep(1,2),rep(0,2)), B = c(0,rep(1,2),0) , 
+                       C = rep(0,4), D = c(rep(0,3),1), cat = c(rep("A",2),"C","B"))
> mat.data
 A B C D cat
 1 0 0 0   A
 1 1 0 0   A
 0 1 0 0   C
 0 0 0 1   B

我设法通过使用匹配函数（例如match(mat.data[,5],colnames(mat.data[1:4]))）来提取匹配值。但是，我无法在合理的时间内获得想要的输出。

我想根据数据的列名和第 5 列之间的真实匹配重新填充 0-1 值（因此，当给定行的第 5 列是 A 时，我希望在列名为“A”，其他列名为“0”）。

为了更好的解释，期望的输出是：

> mat.data
 A B C D cat
 1 0 0 0   A
 1 0 0 0   A
 0 0 1 0   C
 0 1 0 0   B

任何让它变得干净和不那么复杂的建议都会很棒。

【问题讨论】：

标签： r dataframe match

【解决方案1】：

一种可能的方法是使用model.matrix 重新创建矩阵，但首先确保cat 变量具有与原始矩阵的列名对应的级别：

mat.data$cat <- factor(mat.data$cat, levels = head(names(mat.data), -1))
new.mat <- data.frame(model.matrix( ~  mat.data$cat - 1))
names(new.mat) <- levels(mat.data$cat)

new.mat
  A B C D
1 1 0 0 0
2 1 0 0 0
3 0 0 1 0
4 0 1 0 0

【讨论】：

嘿，非常感谢。这在巨大的数据集上运行得非常快。对于增加的列数，它不起作用。但是，当我在这里删除 head = levels = head(names(mat.data), -1)) 中的“-1”时，它起作用了。那太好了，如果我能理解为什么或是否会改变产生的输出，因为我没有机会控制它（大数据集问题）？
如果玩具数据代表真实数据，应该没有问题。无论如何，从head 命令中删除-1 会完全改变结果（默认只返回前6 个值，而使用-1 意味着除了最终值之外的所有值）。相反，您可以使用玩具数据中的names(mat.data)，在最坏的情况下，您应该有一个可以删除的多余列 (cat)。

【解决方案2】：

data.table::dcast 的另一个选项：

library(data.table)
setDT(mat.data)
mat.data[, cat := factor(cat, levels = names(mat.data)[1:4])]
res <- dcast(mat.data, cat + seq_along(cat) ~ cat, fun.agg = length, fill = 0, drop = c(T, F))
res[, cat_1 := NULL]

# > res
#    cat A B C D
# 1:   A 1 0 0 0
# 2:   A 1 0 0 0
# 3:   B 0 1 0 0
# 4:   C 0 0 1 0

【讨论】：

非常感谢提醒我需要更频繁地使用 data.table 的选项。

【解决方案3】：

这是一种使用sapply 并依赖于逻辑到数字转换的方法：

> cat <- c("A", "A", "C", "B")
> lvls <- LETTERS[1:4]
> 
> mat.data <- t(sapply(cat, function(x) as.numeric(lvls == x)))
> colnames(mat.data) <- lvls
> mat.data
  A B C D
A 1 0 0 0
A 1 0 0 0
C 0 0 1 0
B 0 1 0 0

到目前为止所有答案的时间：

> microbenchmark(
+   model.matrix = {
+     mat.data = data.frame(A = c(rep(1,2),rep(0,2)), B = c(0,rep(1,2),0) , 
+                                         C = rep(0,4), D = c(rep(0,3),1), cat = c(rep("A",2),"C","B"))
+     mat.data$cat <- factor(mat.data$cat, levels = head(names(mat.data), -1))
+     new.mat <- data.frame(model.matrix( ~  mat.data$cat - 1))
+     names(new.mat) <- levels(mat.data$cat)
+   },
+   dcast = {
+     mat.data = data.frame(A = c(rep(1,2),rep(0,2)), B = c(0,rep(1,2),0) , 
+                           C = rep(0,4), D = c(rep(0,3),1), cat = c(rep("A",2),"C","B"))
+     setDT(mat.data)
+     mat.data[, cat := factor(cat, levels = names(mat.data)[1:4])]
+     res <- dcast(mat.data, cat + seq_along(cat) ~ cat, fun.agg = length, fill = 0, drop = c(T, F))
+     res[, cat_1 := NULL]
+   },
+   outer = {
+     mat.data = data.frame(A = c(rep(1,2),rep(0,2)), B = c(0,rep(1,2),0) , 
+                           C = rep(0,4), D = c(rep(0,3),1), cat = c(rep("A",2),"C","B"))
+     match_cols <- setdiff(names(mat.data), "cat")
+     new.data <- outer(X = mat.data[["cat"]], Y = match_cols, stringi::stri_count_fixed)
+     colnames(new.data) <- match_cols
+     cbind(new.data, mat.data["cat"])
+   },
+   sapply = {
+     mat.data = data.frame(A = c(rep(1,2),rep(0,2)), B = c(0,rep(1,2),0) , 
+                           C = rep(0,4), D = c(rep(0,3),1), cat = c(rep("A",2),"C","B"))
+     lvls <- LETTERS[1:4]
+     new.mat <- t(sapply(mat.data$cat, function(x) as.numeric(lvls == x)))  
+     colnames(new.mat) <- lvls
+   },
+   tidy = {
+     mat.data = data.frame(A = c(rep(1,2),rep(0,2)), B = c(0,rep(1,2),0) , 
+                           C = rep(0,4), D = c(rep(0,3),1), cat = c(rep("A",2),"C","B"))
+     mat.data[5] %>% 
+       rowid_to_column %>% 
+       mutate(value=1) %>% 
+       spread(cat,value, fill=0) %>%
+       select(-rowid)
+   }
+ )
Using 'cat' as value column. Use 'value.var' to override (x100)
Unit: microseconds
         expr      min       lq      mean    median       uq       max neval
 model.matrix  894.835 1027.983 1185.7946 1173.6940 1313.258  1640.453   100
        dcast 4432.031 4935.079 5603.5700 5290.8000 5725.408 12495.376   100
        outer  508.123  564.671  666.4618  610.9195  758.261  1008.386   100
       sapply  463.534  496.724  611.6146  549.5260  672.997  2526.964   100
         tidy 3936.329 4525.921 5000.3296 4917.7735 5257.409 10660.893   100

【讨论】：

嘿，非常感谢！ sapply 的一个问题是，如果您正在处理大数据，时间效率会变得非常低。
到目前为止，我只是对所有答案进行了微基准测试，至少对于玩具数据集，sapply 是最快的
很高兴看到一个基准。然而，玩具数据集的微基准无法扩展到更大的数据集。如果您使用更大的数据集运行基准测试，例如n <- 10000; mat.data = data.frame(A = sample(0:1, n, replace = T), B = sample(0:1, n, replace = T), C = sample(0:1, n, replace = T), D = sample(0:1, n, replace = T), cat = sample(LETTERS[1:3], n, replace = T))，您会发现model.matrix 是最有效的。

【解决方案4】：

使用outer 和stringi::stri_count_fixed 的解决方案

match_cols <- setdiff(names(mat.data), "cat")
new.data <- outer(X = mat.data[["cat"]], Y = match_cols, stringi::stri_count_fixed)
colnames(new.data) <- match_cols
cbind(new.data, mat.data["cat"])
#  A B C D cat
#1 1 0 0 0   A
#2 1 0 0 0   A
#3 0 0 1 0   C
#4 0 1 0 0   B

没有stringi 你可以这样做

new.data <- 1 * outer(X = mat.data[["cat"]], Y = count_cols, `==`)

【讨论】：

【解决方案5】：

这是基于tidyr::spread 的tidyverse 解决方案：

library(tidyverse)
mat.data[5] %>% 
  rowid_to_column %>% 
  mutate(value=1) %>% 
  spread(cat,value, fill=0) %>%
  select(-rowid)
#   A B C
# 1 1 0 0
# 2 1 0 0
# 3 0 0 1
# 4 0 1 0

如您所见，D 不存在，但如果您的cat 列中有任何"D"，它就会存在。

【讨论】：

嘿，谢谢，在没有列（在本例中为“D”）没有价值的情况下非常实用。