Question

我有来自易货经济的数据。我正在尝试创建一个矩阵，用于计算项目与其他项目作为交易对手的频率。

举个例子：

  myDat <- data.frame(
             TradeID = as.factor(c(1,1,1,2,2,2,3,3,4,4,5,5,6,6,7,7,8,8,8)),
             Origin = as.factor(c(1,0,0,1,1,0,1,0,1,0,1,0,1,0,1,0,1,0,0)),
             ItemID = as.factor(c(1,2,3,4,5,1,1,6,7,1,1,8,7,5,1,1,2,3,4))
            )


     TradeID Origin ItemID
  1        1      1      1
  2        1      0      2
  3        1      0      3
  4        2      1      4
  5        2      1      5
  6        2      0      1
  7        3      1      1
  8        3      0      6
  9        4      1      7
  10       4      0      1
  11       5      1      1
  12       5      0      8
  13       6      1      7
  14       6      0      5
  15       7      1      1
  16       7      0      1
  17       8      1      2
  18       8      0      3
  19       8      0      4
  20       9      1      1
  21       9      0      8

其中TradeID表示特定交易。 ItemID表示项目，Origin指示项目的方向。

例如，根据我的数据，我创建的矩阵看起来像这样： enter image description here

例如，[1,8]处的值2表示项目1＆amp; 8个是两个行业的交易对手。（注意，它是对称矩阵，因此[8,1]也具有值2）。
虽然在[1,2]处的值为1表示项目1和2仅在一次交易中是交易对手（整个矩阵中的所有其他1都表示相同）
作为一个奇怪的例子，注意在[1,1]，值为1表示项目1是自己的对手一次（交易号7）
对我的动机有一点了解，在我的简单例子中注意到，第1项倾向于充当具有许多不同项目的交易对手。在易货经济中（没有明确的货币），我们可能会认为商品货币比非商品货币更频繁地成为交易对手。像这样的矩阵将是发现哪个项目是商品货币的一种方式的第一步。

我一直在努力解决这个问题。但我认为我差不多完成了一个过于复杂的解决方案，我将很快发布。

我很好奇你们是否也可以提供一些帮助。

Answer 1

这将为您提供每个TradeID和ItemID的观察数量

myDat <- data.frame(
  TradeID = as.factor(c(1,1,1,2,2,2,3,3,4,4,5,5,6,6,7,7,8,8,8)),
  Origin = as.factor(c(1,0,0,1,1,0,1,0,1,0,1,0,1,0,1,0,1,0,0)),
  ItemID = as.factor(c(1,2,3,4,5,1,1,6,7,1,1,8,7,5,1,1,2,3,4))
)
result = tapply(myDat$Origin, list(myDat$ItemID,myDat$TradeID), length)
result[is.na(result)] = 0
result["1","7"]

结果将是：

> result
  1 2 3 4 5 6 7 8
1 1 1 1 1 1 0 2 0
2 1 0 0 0 0 0 0 1
3 1 0 0 0 0 0 0 1
4 0 1 0 0 0 0 0 1
5 0 1 0 0 0 1 0 0
6 0 0 1 0 0 0 0 0
7 0 0 0 1 0 1 0 0
8 0 0 0 0 1 0 0 0

这将为您提供每个TradeID和ItemID 1 Origin的比例

result = tapply(myDat$Origin, list(myDat$ItemID,myDat$TradeID), function(x) { sum(as.numeric(as.character(x)))/length(x) })

您可以使用NA将最后一个矩阵中的result[is.na(result)] = 0值设置为0，但除了0原点交易之外，不会有任何观察结果。

Answer 2

好吧，我想我已经搞清楚了。简短的回答是：

Reduce("+",by(myDat, myDat$TradeID, function(x) pmin(table(x$ItemID[x$Origin==0]) %o% table(x$ItemID[x$Origin==1]) + table(x$ItemID[x$Origin==1]) %o% table(x$ItemID[x$Origin==0]),1)))

给出以下矩阵，匹配所需的结果：

  1 2 3 4 5 6 7 8
1 1 1 1 1 1 1 1 2
2 1 0 1 1 0 0 0 0
3 1 1 0 0 0 0 0 0
4 1 1 0 0 0 0 0 0
5 1 0 0 0 0 0 1 0
6 1 0 0 0 0 0 0 0
7 1 0 0 0 1 0 0 0
8 2 0 0 0 0 0 0 0

这是一个很长的答案。您可以使用TradeID和by（outer）和%o%函数获取每个table的矩阵列表。但这会重复交易7，其中第1项交易第1项，因此我使用pmax函数来解决此问题。然后，我使用Reduce函数在列表中求和。

这是实现目标的步骤。请注意添加TradeID＃9，这是问题代码之外的。

# Data
myDat <- data.frame(
  TradeID = as.factor(c(1,1,1,2,2,2,3,3,4,4,5,5,6,6,7,7,8,8,8,9,9)),
  Origin = as.factor(c(1,0,0,1,1,0,1,0,1,0,1,0,1,0,1,0,1,0,0,1,0)),
  ItemID = as.factor(c(1,2,3,4,5,1,1,6,7,1,1,8,7,5,1,1,2,3,4,1,8))
)

# Sum in 1 direction
by(myDat, myDat$TradeID, function(x) table(x$ItemID[x$Origin==0]) %o% table(x$ItemID[x$Origin==1]))

# Sum in both directions
by(myDat, myDat$TradeID, function(x) table(x$ItemID[x$Origin==1]) %o% table(x$ItemID[x$Origin==0]) + table(x$ItemID[x$Origin==0]) %o% table(x$ItemID[x$Origin==1]))

# Remove double-count in trade 7
by(myDat, myDat$TradeID, function(x) pmin(table(x$ItemID[x$Origin==0]) %o% table(x$ItemID[x$Origin==1]) + table(x$ItemID[x$Origin==1]) %o% table(x$ItemID[x$Origin==0]),1))

# Sum across lists
Reduce("+",by(myDat, myDat$TradeID, function(x) pmin(table(x$ItemID[x$Origin==0]) %o% table(x$ItemID[x$Origin==1]) + table(x$ItemID[x$Origin==1]) %o% table(x$ItemID[x$Origin==0]),1)))

加快这种速度的一种方法是仅在1个方向上求和（利用对称性），然后清理结果。

result = Reduce("+",by(myDat, myDat$TradeID, function(x) table(x$ItemID[x$Origin==0]) %o% table(x$ItemID[x$Origin==1])))
result2 = result + t(result)
diag(result2) = diag(result)
result2
    1 2 3 4 5 6 7 8
  1 1 1 1 1 1 1 1 2
  2 1 0 1 1 0 0 0 0
  3 1 1 0 0 0 0 0 0
  4 1 1 0 0 0 0 0 0
  5 1 0 0 0 0 0 1 0
  6 1 0 0 0 0 0 0 0
  7 1 0 0 0 1 0 0 0
  8 2 0 0 0 0 0 0 0

这似乎快了两倍。

> microbenchmark(Reduce("+",by(myDat, myDat$TradeID, function(x) pmin(table(x$ItemID[x$Origin==0]) %o% table(x$ItemID[x$Origin==1]) + table(x$ItemID[x$Origin==1]) %o% table(x$ItemID[x$Origin==0]),1))))
Unit: milliseconds
      min       lq   median       uq     max neval
 7.489092 7.733382 7.955861 8.536359 9.83216   100

> microbenchmark(Reduce("+",by(myDat, myDat$TradeID, function(x) table(x$ItemID[x$Origin==0]) %o% table(x$ItemID[x$Origin==1]))))
Unit: milliseconds

      min      lq   median       uq      max neval
 4.023964 4.18819 4.277767 4.452824 5.801171   100

Answer 3

这将为您提供每个连续ItemID的观察次数：

idxList <-  with(myDat, tapply(ItemID, TradeID, FUN = function(items) 
  lapply(seq(length(items) - 1), 
         function(i) sort(c(items[i], items[i + 1])))))

# indices of observations  
idx <- do.call(rbind, unlist(idxList, recursive = FALSE))

# create a matrix
ids <- unique(myDat$ItemID)
mat <- matrix(0, length(ids), length(ids))

# place values in matrix
for (i in seq(nrow(idx))) {
  mat[idx[i, , drop = FALSE]] <- mat[idx[i, , drop = FALSE]] + 1      
}

# create symmatric marix 
mat[lower.tri(mat)] <- t(mat)[lower.tri(mat)]


     [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
[1,]    1    1    0    0    1    1    1    1
[2,]    1    0    2    0    0    0    0    0
[3,]    0    2    0    1    0    0    0    0
[4,]    0    0    1    0    1    0    0    0
[5,]    1    0    0    1    0    0    1    0
[6,]    1    0    0    0    0    0    0    0
[7,]    1    0    0    0    1    0    0    0
[8,]    1    0    0    0    0    0    0    0

R-创建对方频率矩阵

3 个答案: