复杂的长到宽重塑算法

如何解决复杂的长到宽重塑算法

我有一个问题，我需要根据 ID1 和 ID2 将长格式数据表改造成宽格式，并且条目不重叠。逻辑相当复杂，取决于 3 列（“Seq、“ID1”和“ID2”）。

如果属于 ID1 的 Value_1 与 ID2“重叠”，则应求和，反之亦然，但仅适用于不同的 ID。

请参阅下面的输入示例和输出，希望能澄清它。

输入：

df <- structure(list(Seq = c(9143L,916L,9293L,9301L,9302L,9304L,9305L,9306L,9307L,931L,9311L),ID1 = c("ID1_1","ID1_1",NA,"ID1_2","ID1_3","ID1_4","ID1_4"),value_1 = c(30L,30L,50L,50L),ID2 = c(NA,"ID2_1","ID2_2","ID2_3","ID2_4","ID2_5"),value_2 = c(NA,33L,200L,46L,58L,46L)),class = "data.frame",row.names = c(NA,-11L))

输出：

（注意例如最后一行，value_1 = 80，因为将属于 ID1_3 和 ID1_4 的值相加得到 30+50）

解决方法

我使用了 data.table 包中的 rleid() 函数，这是一个计算游程编码的迷人函数。这样做

library(data.table)
library(dplyr)
df %>% 
  mutate(d = cumsum( c(0,diff(rleid(ID1))) != 0 & c(0,diff(rleid(ID2))) != 0),value_1 = value_1 * c(1,diff(rleid(ID1))),value_2 = value_2 * c(1,diff(rleid(ID2)))) %>% group_by(d) %>%
  summarise(Seq = toString(Seq),value_1 = sum(value_1,na.rm = T),value_2 = sum(value_2,na.rm = T)) %>%
  ungroup() %>% select(-d)

# A tibble: 4 x 3
  Seq                               value_1 value_2
  <chr>                               <int>   <int>
1 9143,916                              30       0
2 9293                                    0      33
3 9301,9302                             30     246
4 9304,9305,9306,9307,931,9311      80     104

旧答案

df %>% group_by(d = cumsum( c(0,diff(rleid(ID2))) != 0)) %>%
  summarise(Seq = toString(Seq),value_1 = sum(unique(value_1),value_2 = sum(unique(value_2),na.rm = T)) %>%
  ungroup() %>% select(-d)

,

首先，我真的很喜欢 AnilGoyal 的解决方案。我可以看到我需要开始使用 data.table 包。

话虽如此，我正在研究一种没有 data.table 的 dplyr 方法，这显然更加冗长。此外，我花了一段时间才弄清楚如何处理重复值。乘以 changei 列（0 或 1）删除重复项。以下是我的方法：

df %>% 
  mutate_if(is.numeric,replace_na,0) %>% 
  mutate_if(is.character,"NA") %>% 
  mutate(
    change1 = ID1 != lag(ID1,default = "Start"),value_1 = value_1 * change1,change2 = ID2 != lag(ID2,value_2 = value_2 * change2,change = cumsum(change1 & change2)
  ) %>% 
  group_by(change) %>% 
  summarise(
    Seq = toString(Seq),na.rm = T)
  ) %>% 
  ungroup()

结果是：

df
#   change Seq                               value_1 value_2
#    <int> <chr>                               <dbl>   <dbl>
# 1      1 9143,916                              30       0
# 2      2 9293                                    0      33
# 3      3 9301,9302                             30     246
# 4      4 9304,9311      80     104

,

不像上面那样简洁，但仍然是一个基本的 R 解决方案：

# Function to calculate the aggregate value: .agg_func => function() 
.agg_func <- function(df,id_col,value_col){
  sbst <- subset(
    df,!(is.na(df[,id_col])) & !(duplicated(df[,id_col])),select = c(id_col,value_col)
  )
  return(sum(sbst[,value_col],na.rm = TRUE))
}

# Function to group data by ids: .grouping_func => function() 
.grouping_func <- function(df,id_col){
  r_l_e <- rle(df[,id_col])
  rle_id <- rep(seq_along(r_l_e$values),times = r_l_e$lengths)
  return(c(0,diff(rle_id)) != 0)
}

# Group the data: grpd_df => data.frame 
grpd_df <- transform(
  df,grp = cumsum(
    apply(
      vapply(
        names(df)[startsWith(names(df),"ID")],function(x).grouping_func(df,x),logical(nrow(df))
        ),1,all
    )
  )
)  

# Split-apply-combine the aggregate function to the grouped data: 
data.frame(do.call(rbind,lapply(with(grpd_df,split(grpd_df,grp)),function(s){
        data.frame(
          Seq = toString(s$Seq),value_1 = .agg_func(s,"ID1","value_1"),value_2 = .agg_func(s,"ID2","value_2")
        )
      }
    )
  ),row.names = NULL,stringsAsFactors = FALSE
)