查找需要解析数据框的组合频率

Question

我相信这个问题有一个简单的解决方案，但我想不出来！！假设我有一个包含以下信息的数据框：

aaa<-c("A,B","B,C","B,D,E")
vvv<-c("101","101,102","102,103,104")
data_h<-data.frame(aaa,vvv)
data_h
    aaa         vvv
1   A,B         101
2   B,C     101,102
3 B,D,E 102,103,104

期望的输出是每个点击的频率图，用于后续在热图中分析。因此：

  101   102   103   104
A  1     0     0     0
B  2     2     1     1
C  1     1     0     0
D  0     1     1     1
E  0     1     1     1

我该如何进行这个转换呢？我看过很多类似的例子，但是没有一个需要解析数据框内容的。

最终的目标是使用热图或者其他类似的输出表格来展示"aaa"和"vvv"之间的相关性。

- Amit Kohli

---

第一行只有101，但它仍然与B进行了映射，而接下来的两行已经分别映射为aaa和vvv... 如何处理这个问题... - vrajs5

抱歉，我不明白......你的问题是什么？ - Amit Kohli

Answer 1

数据框的形状表明需要使用splitstackshape包。但是我不太了解这个包，所以我只是用它来重塑数据，然后手动使用table计算频率：

library(splitstackshape)
data_h_split <- concat.split.multiple(data_h,1:2)

# aaa_1 aaa_2 aaa_3 vvv_1 vvv_2 vvv_3
# 1     A     B  <NA>   101    NA    NA
# 2     B     C  <NA>   101   102    NA
# 3     B     D     E   102   103   104

一旦您的数据格式符合此格式（没有逗号，列规则），使用table（您可以使用tapply，reshape）计算频率就变得容易了：

table(cbind.data.frame(ff= unlist(data_h_split[1:3]),
                       xx= unlist(data_h_split[4:6])))
   xx
ff  101 102 103 104
  A   1   0   0   0
  B   1   1   0   0
  C   0   1   0   0
  D   0   0   1   0
      0   0   0   0
  E   0   0   0   1

---

Ananda的编辑

以下是使用“splitstackshape”实现结果的多步骤方法。

library(splitstackshape)

## Split the "vvv" column first, and reshape at the same time
x <- concat.split.multiple(data_h, split.cols="vvv", ",", "long")

## Add an ID column
x$id <- 1:nrow(x)

## Split the "aaa" column next, again reshaping as we do so
x <- concat.split.multiple(x[complete.cases(x), ], split.cols="aaa", ",", "long")

## Use `table` with `droplevels`
with(droplevels(x), table(aaa, vvv))
#    vvv
# aaa 101 102 103 104
#   A   1   0   0   0
#   B   2   2   1   1
#   C   1   1   0   0
#   D   0   1   1   1
#   E   0   1   1   1

- agstudy

---

这绝对有效...我暂时不标记为已解决，因为它不太可推广，因为在我的应用程序中，我需要找出列是[1:208]和[209:416]...但还是谢谢你，干得好！ - Amit Kohli

@AmitKohli，如果列名相似，你不能只是使用带有列名的grep吗？ - A5C1D2H2I1M1N2O1R2T1

@AnandaMahto，感谢您的编辑。我不介意任何编辑 :) 您随时受欢迎。 - agstudy

无法复现您的编辑 Ananda... 当我尝试在我的真实数据上运行时，它会使我的计算机冻结（但我的计算机不是很好...所以这可能不是您的代码问题）。关于您的评论，您希望我查找什么？ - Amit Kohli

@AmitKohli，请查看我在此答案中发布的结果：https://dev59.com/-IDba4cB1Zd3GeqPE3_s#24146951 - A5C1D2H2I1M1N2O1R2T1

Answer 2

这里提供了一个基于R语言的解决方案，仅需4行代码。 首先，我们定义了一个名为“spl”的函数，该函数将逗号分隔的字符串组件拆分为所有字段的向量。接下来，“eg”接收两个字符串参数，并对每个字符串应用“spl”，然后创建一个结果拆分的网格。最后，我们将“eg”应用于“data_h”的每一行，将结果进行“rbind”，并使用“xtabs”进行制表：

spl <- function(x) strsplit(as.character(x), ",")[[1]]
eg <- function(aaa, vvv) expand.grid(aaa = spl(aaa), vvv = spl(vvv))
dd <- do.call("rbind", Map(eg, data_h$aaa, data_h$vvv))
xtabs(data = dd)

结果是：

   vvv
aaa 101 102 103 104
  A   1   0   0   0
  B   2   2   1   1
  C   1   1   0   0
  D   0   1   1   1
  E   0   1   1   1

dcast可以替换上述代码中的最后一行（即包含xtabs的那一行）：

library(reshape2)
dcast(dd, aaa ~ vvv, fun = length, value.var = "vvv")

在这种情况下，结果是:

  aaa 101 102 103 104
1   A   1   0   0   0
2   B   2   2   1   1
3   C   1   1   0   0
4   D   0   1   1   1
5   E   0   1   1   1

tapply。另一个选择是tapply（但它会用NA而不是0填充空单元格）：

tapply(1:nrow(dd), dd, length)

新增替代品。一些改进。

- G. Grothendieck

---

这几乎让我的计算机处理崩溃，但也能工作！不幸的是，它给出了与上面的splitstackshape解决方案不同的答案...尝试编辑。 - Amit Kohli

我不确定你所说的“不幸”是什么意思。这提供了问题中所要求的答案。 - G. Grothendieck

@AmitKohli，我也不理解你在评论中使用“不幸”一词的意思。 - A5C1D2H2I1M1N2O1R2T1

“不幸的是”，这意味着我必须手动检查真实数据以确定其准确性。但由于我无法在splitstackshape中重现编辑，因此我将其标记为答案。谢谢！ - Amit Kohli

如果去除0的意思是将它们替换为NA，则在dcast语句中添加fill=NA_integer_参数。 - G. Grothendieck

Answer 3

我的concat.split.multiple函数非常需要重写以提高效率。我已经在cSplit函数中进行了一些工作，如果您有一个特别大的数据集，这可能会很有用。

以下是我如何使用cSplit解决您提供的问题：

table(
  cSplit(
    cSplit(data_h, splitCols = 2, sep = ",", 
           direction = "long", makeEqual = FALSE), 
    splitCols = 1, sep = ",", direction = "long", 
    makeEqual = FALSE))
#    vvv
# aaa 101 102 103 104
#   A   1   0   0   0
#   B   2   2   1   1
#   C   1   1   0   0
#   D   0   1   1   1
#   E   0   1   1   1

看起来这东西也相当有效...

首先，要测试的函数：

fun1 <- function() table(cSplit(cSplit(df, 2, ",", "long", FALSE), 1, ",", "long", FALSE))

fun2 <- function() {
  spl <- function(x) strsplit(as.character(x), ",")[[1]]
  eg <- function(aaa, vvv) expand.grid(aaa = spl(aaa), vvv = spl(vvv))
  dd <- do.call("rbind", Map(eg, df$A, df$V))
  xtabs(data = dd)
}

其次，是一些样本数据。更改 Nrows 并重新生成以查看对不同大小的 data.frame 的影响。

set.seed(1)
Nrow <- 100
aaa <- 100:200
vvv <- LETTERS
maxA <- 10
maxV <- 10
Aaa <- sample(maxA, Nrow, TRUE)
Vvv <- sample(maxV, Nrow, TRUE)
A <- vapply(seq_along(Aaa), function(x) 
  paste(sample(aaa, Aaa[x], TRUE), collapse = ","), character(1L))
V <- vapply(seq_along(Vvv), function(x) 
  paste(sample(vvv, Vvv[x], TRUE), collapse = ","), character(1L))
df <- data.frame(A, V)
head(df)
#                                         A                   V
# 1                             127,122,152       E,E,O,S,W,S,M
# 2                         127,118,152,156             V,A,Z,Q
# 3                 113,125,172,197,110,177               L,A,T
# 4 195,182,131,165,196,196,134,126,116,132 F,Z,X,S,T,M,W,E,Q,H
# 5                             151,193,151       L,B,E,B,Y,I,N
# 6     126,104,142,186,135,113,137,163,139               Q,G,N

比较这两种方法以确保结果相同：

X <- fun1()
Y <- fun2()
all(X == Y[dimnames(X)[[1]], dimnames(X)[[2]]])
# [1] TRUE

基准测试（针对100行数据）。

library(microbenchmark)
## Nrow = 100
microbenchmark(fun1(), fun2(), times = 10)
# Unit: milliseconds
#    expr       min        lq    median        uq      max neval
#  fun1()  7.263802  7.326237  7.440843  7.868905 10.26451    10
#  fun2() 62.869130 64.046836 68.525880 73.595061 80.02027    10

基准测试（针对1000行数据）。

## Nrow = 1000
microbenchmark(fun1(), fun2(), times = 10)
# Unit: milliseconds
#    expr      min        lq    median        uq       max neval
#  fun1()  19.2303  20.21857  23.14337  26.97776  35.56338    10
#  fun2() 775.6586 815.01639 835.98951 852.47804 888.15345    10

- A5C1D2H2I1M1N2O1R2T1