Создайте фрейм данных 0-1 на основе совпадающих значений в именах столбцов и определенного столбца в R

Question

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

Вот гипотетический фрейм данных:

> 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]))). Тем не менее, я не смог получить результат, который хотел получить за разумное время.

Я хочу заново заполнить значения 0-1 на основе истинного соответствия между именами столбцов данных и 5-м столбцом (поэтому, когда 5-й столбец является A для данной строки, я хочу, чтобы "1" под столбец с именем «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 

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

Answer 1

Вот решение tidyverse на основе tidyr::spread:

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".

Answer 2

Вот способ использования 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

Answer 3

Решение с использованием 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, `==`)

Answer 4

Другой вариант с 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

Answer 5

Одним из возможных подходов было бы воссоздание матрицы с использованием 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