Question

我有一个对称的流量矩阵（tibble形式），类似于下面的示例：

library(tibble)
set.seed(2019)

df1 <- as_tibble(matrix(sample(1:10,100,replace = T), nrow = 10, ncol = 10, byrow = TRUE,
               dimnames = list(as.character(1:10),
                               as.character(1:10))))

df1
#     `1`   `2`   `3`   `4`   `5`   `6`   `7`   `8`   `9`  `10`
#   <int> <int> <int> <int> <int> <int> <int> <int> <int> <int>
# 1     8     8     4     7     1     1     9     1     2     7
# 2     8     7     3     2     7     7     1     8     4     5
# 3     5     6    10     2     2     1     6    10     7     5
# 4     7     1     9     2     1     1     4     5     1     8
# 5     7     3     9     7     9     5    10    10     3     2
# 6     4     1     1     4     6     4    10    10     1     1
# 7     2     3     8     4     8    10     4     1     9     6
# 8     4     2     4     2     7    10     2     6     4     8
# 9     1    10    10     3     6     2     6     7     8     4
#10     6     8     9     3     6     9     5    10     4    10

我还有一个查找表，显示每个流子组适合的大致组：

lookup <- tibble(sector = as.character(1:10),
                     aggregate_sector = c(rep('A',3), rep('B', 3), rep('C', 4)))
lookup
#   sector aggregate_sector
#1       1                A
#2       2                A
#3       3                A
#4       4                B
#5       5                B
#6       6                B
#7       7                C
#8       8                C
#9       9                C
#10     10                C

我想总结一下我的原始df1，以便它表示每个aggregate_sector（根据查询表）而不是每个sector之间的流。预期输出：

#   A  B  C
#A 59 30 65
#B 42 39 65
#C 67 70 94

我最初的尝试是转换为矩阵，然后使用嵌套的for循环依次计算每个aggregate_sector组合的流量总和：

mdat <- as.matrix(df1)

# replace row and column names with group names - assumes lookup is in same order as row and col names...
row.names(mdat) <- lookup$aggregate_sector
colnames(mdat) <- lookup$aggregate_sector

# pre-allocate an empty matrix
new_mat <- matrix(nrow = 3, ncol = 3, dimnames = list(LETTERS[1:3], LETTERS[1:3]))

# fill in matrix section by section
for(i in row.names(new_mat)){
  for(j in colnames(new_mat)){
    new_mat[i,j] <- sum(mdat[which(row.names(mdat) ==i), which(colnames(mdat) ==j)])
  }
}


new_mat

#   A  B  C
#A 59 30 65
#B 42 39 65
#C 67 70 94

虽然这是一个令人满意的解决方案，但我想知道是否存在使用dplyr或类似方法的解决方案，该解决方案使用了更好的逻辑，并且使我不必将实际数据（tibble）转换为矩阵表格。

Answer 1

关键步骤是收集-之后就是所有简单的dplyr内容：


flow_by_sector <- 
  df1 %>%
  mutate(sector_from = rownames(.)) %>%
  tidyr::gather(sector_to, flow, -sector_from)


flow_by_sector_with_agg <- 
  flow_by_sector %>%
  left_join(lookup, by = c("sector_from" = "sector")) %>%
  rename(agg_from = aggregate_sector) %>%
  left_join(lookup, by = c("sector_to" = "sector")) %>%
  rename(agg_to = aggregate_sector)

flow_by_agg <- 
  flow_by_sector_with_agg %>%
  group_by(agg_from, agg_to) %>%
  summarise(flow = sum(flow))

tidyr::spread(flow_by_agg, agg_to, flow)

Answer 2

这是使用stack和xtabs的基本答案。它不是非常健壮-它假定查找表具有与data.frame中表示的列和顺序相同的列和顺序。

colnames(df1) <- lookup$aggregate_sector

xtabs(values ~ sector + ind
      , dat = data.frame(sector = rep(lookup$aggregate_sector
                                    , length(df1)), stack(df1))
      )

这是另一种处理data.frame的方法：

xtabs(values ~ Var1 + Var2,
      dat = data.frame(expand.grid(lookup$aggregate_sector, lookup$aggregate_sector)
                       , values = unlist(df1))
)
    Var2
Var1  A  B  C
   A 59 30 65
   B 42 39 65
   C 67 70 94

Answer 3

实际上我想出了一个矩阵代数替代我的问题，尽管必须将我的data.frame转换为matrix，但它的速度要快得多。我不会接受此解决方案，因为我确实确实要求dplyr的答案，但无论如何都认为足够有趣，可以在此处发布。

我首先必须从我的查询表中形成一个调整矩阵S，其中S的第i行中那些位置的位置指示原始矩阵的哪些扇区将在汇总矩阵中作为扇区i分组在一起：

S <- lookup %>% mutate(sector = as.numeric(sector), value = 1)  %>%
  spread(sector, value) %>%
  column_to_rownames('aggregate_sector') %>%
  as.matrix()

S[is.na(S)] <- 0

S

#  1 2 3 4 5 6 7 8 9 10
#A 1 1 1 0 0 0 0 0 0  0
#B 0 0 0 1 1 1 0 0 0  0
#C 0 0 0 0 0 0 1 1 1  1

然后，我将原来的data.frame df1转换为matrix x并简单地计算S.x.S'：

x <- as.matrix(df1)

S %*% x %*% t(S)

#   A  B  C
#A 59 30 65
#B 42 39 65
#C 67 70 94

汇总已知分组中的行和列

3 个答案: