在先前重塑的索引列之后重塑多组变量答案

【问题标题】：Reshape several groups of variables, following a previously reshaped index column在先前重塑的索引列之后重塑多组变量
【发布时间】：2021-01-25 03:58:41
【问题描述】：

我正在尝试在 R 中将 data.table 从宽变为长。我需要减少几组变量，但我最初一次做一组的方法看起来很容易出错，我'想要一个替代方案。在这个可重现的示例中，我以与原始数据类似的方式创建了两组变量（XX 和 YYY）。

我的解决方案在此示例中有效，但原始数据表包含太多列，以至于我对信任此代码感到不安。我不确定问题出在我的实现还是方法本身 - 如果可能，我更喜欢keep it simple。

问：有没有更好的方法来解决这个问题？

示例数据

library(data.table)

dt.orig <- data.table(ID= 1:3,
                      a = c("Y", "Y", "N"),
                      b = c("N", "Y", "Y"),
                      XXa=c(101, 102, 103),
                      XXb=c(110, 120, 130),
                      YYYa=c(201, 202, 203),
                      YYYb=c(210, 220, 230))


dt.goal <- data.table(ID=c(1,1,2,2,3,3),
                      obs=c("a", "b"),
                      outcome = c("Y", "N", "Y", "Y", "N", "Y"),
                      XX=c(101, 110, 102, 120, 103, 130),
                      YYY=c(201, 210, 202, 220, 203, 230))

> dt.orig
   ID a b XXa XXb YYYa YYYb
1:  1 Y N 101 110  201  210
2:  2 Y Y 102 120  202  220
3:  3 N Y 103 130  203  230
> dt.goal
   ID obs outcome  XX YYY
1:  1   a       Y 101 201
2:  1   b       N 110 210
3:  2   a       Y 102 202
4:  2   b       Y 120 220
5:  3   a       N 103 203
6:  3   b       Y 130 230

dt.orig代表原始数据，dt.goal是我打算实现的。我在tidyr 包小插图之后的初步尝试如下：

尝试 1：tidyr/dplyr 方法

library(tidyr)
library(dplyr)

dt.orig[, .(ID, a, b)] %>%
  pivot_longer(
    cols = c("a", "b"),
    names_to = "obs",
    values_to = "outcome"
  ) %>% data.table -> dt.tidyr1

dt.orig[, .(ID, XXa, XXb, YYYa, YYYb)] %>%
  pivot_longer(
             cols = XXa:YYYb,
             names_to = c(".value", "obs"),
             names_pattern = "(XX|YYY)(.)",
              ) %>% data.table -> dt.tidyr2

dt.tidyr1[, .(ID, obs, outcome)] == dt.goal[, .(ID, obs, outcome)] # test passes
dt.tidyr2[, .(ID, obs, XX, YYY)] == dt.goal[, .(ID, obs, XX, YYY)] # test passes

> merge(dt.tidyr1, dt.tidyr2)
   ID obs outcome  XX YYY
1:  1   a       Y 101 201
2:  1   b       N 110 210
3:  2   a       Y 102 202
4:  2   b       Y 120 220
5:  3   a       N 103 203
6:  3   b       Y 130 230

在上面的代码中，我首先为obs 和a 和b 的结果创建了一对名称/值。由于所有变量组在其命名方案中都包含a 和b，因此我可以使用这一事实通过单个regex 传递所有组。

然后我可以将两个数据表合并或连接到最终结果中。

尝试 2：data.table 方式

按照相同的原则，我可以开始将原始 a 和 b 融合为 obs 和结果，然后针对每个 var 组进行第二步（为简洁起见，此处未显示）。在这种情况下，我一次成功地融合了一个 var 组，因此在此示例中，首先执行所有 XX，然后执行所有 YYY。优点/缺点：优点是我不需要创建几个步骤表来完成这个过程。缺点：世界上没有足够的咖啡来使用实际数据中的所有 var 组来完成这种方法（并相信结果）。

dt.melt1 <- melt(dt.orig,
                 id.vars = c("ID", "XXa", "XXb", "YYYa", "YYYb"),
                 measure = c("a", "b"),
                 variable.name = "obs",
                 value.name = "outcome")

【问题讨论】：

标签： r data.table reshape tidyr

【解决方案1】：

我认为 dplyr 版本很好。您可以使 pivot_longer 中的正则表达式更通用，以增加列数。您还可以将列 a 和 b 展平为一个列表，这样您就不必处理创建第二个数据框和合并。

# flatten cols a,b 
outcome <-  c(t(select(dt.orig, c(a, b))))

# pivot longer on regex and add outcome list
dt.orig %>%  
  pivot_longer(-c(ID, a, b), 
               names_to = c(".value", "obs"),
               names_pattern = "(.*)(.)") %>% 
  mutate(outcome = outcome) %>% 
  select(-c(a, b))



     ID obs      XX   YYY outcome
1     1 a       101   201 Y      
2     1 b       110   210 N      
3     2 a       102   202 Y      
4     2 b       120   220 Y      
5     3 a       103   203 N      
6     3 b       130   230 Y

【讨论】：

谢谢。您正确地猜到了我遗漏的问题：我想避免创建第二个要合并的表。您提供的正则表达式是否会匹配我在此示例中未包含的所有其他列？

【解决方案2】：

我认为data.table::melt 没有自动将“XXa”拆分为“XX”和“a”的机制，因此您可能别无选择，只能使用data.table 进行多个步骤.但这里有两种获得结果的替代方法，与@LRRR 的漂亮 tidyverse 解决方案进行快速基准测试。

数据和库：

library(data.table)
library(tidyverse)
library(microbenchmark)

dt.orig = data.table(ID= 1:3,
                     a = c("Y", "Y", "N"),
                     b = c("N", "Y", "Y"),
                     XXa=c(101, 102, 103),
                     XXb=c(110, 120, 130),
                     YYYa=c(201, 202, 203),
                     YYYb=c(210, 220, 230))

第一个data.table 解决方案（包装在一个函数中用于基准测试）：

dt_1 <- function() {
  dt = melt(dt.orig, 
            id.vars=c("a", "b", "ID"), 
            measure.vars=patterns("XX|YYY"),
            variable.factor=FALSE)
  dt = melt(dt,
            id.vars=c("ID", "variable", "value"),
            value.name="outcome",
            variable.name="obs",
            variable.factor=FALSE)
  dt = dt[substr(variable, nchar(variable), nchar(variable)) == obs]
  dt[, variable := substr(variable, 1, nchar(variable)-1)]
  dcast(dt, ID + obs + outcome ~ variable)
}

第二个data.table解决方案：

dt_2 <- function() {
  # ID-obs-outcome
  dt1 = melt(dt.orig[, .(ID, a, b)], 
             id.vars="ID",
             value.name="outcome",
             variable.name="obs",
             variable.factor=FALSE)

  # ID-obs-XX-YYY 
  dt2 = melt(dt.orig[, !c("a", "b")], 
             id.vars="ID",
             variable.factor=FALSE)
  dt2[, obs := substr(variable, nchar(variable), nchar(variable))]
  dt2[, variable := substr(variable, 1, nchar(variable)-1)]
  dt2 = dcast(dt2, ID + obs ~ variable)

  # merge
  merge(dt1, dt2, by=c("ID", "obs"))
}

tidyverse 解决方案由 LRRR 作为工作答案发布：

tidy_1 <- function(){
  # flatten cols a,b 
  outcome <-  c(t(select(dt.orig, c(a, b))))
  # pivot longer on regex and add outcome list
  dt.orig %>%  
    pivot_longer(-c(ID, a, b), 
                 names_to = c(".value", "obs"),
                 names_pattern = "(.*)(.)") %>% 
    mutate(outcome = outcome) %>% 
    select(-c(a, b))
}

基准测试：

microbenchmark(dt_1(), dt_2(), tidy_1(), times=20)
#> Unit: milliseconds
#>      expr       min        lq      mean    median        uq      max neval cld
#>    dt_1()  2.695407  2.716623  4.968294  2.900856  3.101634 43.51289    20  a 
#>    dt_2()  4.849555  5.027214  6.704733  5.160479  6.297621 18.93398    20  a 
#>  tidy_1() 13.149104 13.515273 16.439809 13.769746 15.506042 47.13444    20   b

【讨论】：

【解决方案3】：

您可以通过两行来实现：

dt.res <- melt(dt.orig, "ID", patterns("^[ab]$", "^XX", "^YYY"), "obs", c("outcome", "XX", "YYY"))
setorder(dt.res, ID)[, obs := unname(c("1" = "a", "2" = "b")[obs])]

输出

> dt.res[]
   ID obs outcome  XX YYY
1:  1   a       Y 101 201
2:  1   b       N 110 210
3:  2   a       Y 102 202
4:  2   b       Y 120 220
5:  3   a       N 103 203
6:  3   b       Y 130 230

这是上面相同代码的稍长版本

dt.res <- 
  melt(
    dt.new2, 
    id.vars = "ID", measure.vars = patterns("^[ab]$", "^XX", "^YYY"), 
    variable.name = "obs", value.name = c("outcome", "XX", "YYY")
  )
setorder(dt.res, ID)[, obs := unname(c("1" = "a", "2" = "b")[obs])]

补充说明

似乎除了ID 列之外，您还有三组需要同时旋转的列：没有任何前缀的列（即a 和b），前缀为XX 的列和那些带有前缀YYY。如果在每个组中，后缀为a 的列始终出现在后缀为b的列之前，则您可以同时melt 这些列组，如data.table v1.9.6 和之后本机支持此类手术。您需要使用regex 指定每个列组。

这就是我们有patterns("^[ab]$", "^XX", "^YYY") 的原因，它捕获了我们尝试melt 的三个列组。在melt 操作之后，你会得到一个data.table 这样的：

   ID obs outcome  XX YYY
1:  1   1       Y 101 201
2:  2   1       Y 102 202
3:  3   1       N 103 203
4:  1   2       N 110 210
5:  2   2       Y 120 220
6:  3   2       Y 130 230

我们在obs 中得到1 和2 而不是a 和b，因为melt 操作自动将每个组中的第一个匹配设置为"1"，第二个设置为"2" ，等等。稍后我们可以通过指定"1" = "a" 和"2" = "b" 来重置此列。但是，您可能知道，如果带有后缀 a 的列出现在带有 b 的列之后，那么我们不能再使用此映射 c("1" = "a", "2" = "b")。这就是为什么我们必须确保每个列组都正确排序。

要更好地说明此排序问题，请参阅以下代码：

# Assume that your data.table looks like this
> dt.unordered
   ID b a XXa YYYb XXb YYYa
1:  1 N Y 101  210 110  201
2:  2 Y Y 102  220 120  202
3:  3 Y N 103  230 130  203

# See the difference now?
> dt.wrong <- melt(dt.unordered, "ID", patterns("^[ab]$", "^XX", "^YYY"), "obs", c("outcome", "XX", "YYY"))
> dt.wrong[]
   ID obs outcome  XX YYY
1:  1   1       N 101 210
2:  2   1       Y 102 220
3:  3   1       Y 103 230
4:  1   2       Y 110 201
5:  2   2       Y 120 202
6:  3   2       N 130 203

因此，如果您无法确保每个组内的顺序，也许可以进行预处理以修复列顺序。这样，你也可以得到正确的结果。

> setcolorder(dt.unordered, sort(names(dt.unordered)))
> dt.fixed <- melt(dt.unordered, "ID", patterns("^[ab]$", "^XX", "^YYY"), "obs", c("outcome", "XX", "YYY"))
> dt.fixed[]
   ID obs outcome  XX YYY
1:  1   1       Y 101 201
2:  2   1       Y 102 202
3:  3   1       N 103 203
4:  1   2       N 110 210
5:  2   2       Y 120 220
6:  3   2       Y 130 230

总而言之，如果您已预订所有列，请执行以下操作：

dt.res <- melt(dt.orig, "ID", patterns("^[ab]$", "^XX", "^YYY"), "obs", c("outcome", "XX", "YYY"))
setorder(dt.res, ID)[, obs := unname(c("1" = "a", "2" = "b")[obs])]

如果没有，请执行以下操作：

setcolorder(dt.orig, sort(names(dt.orig)))
dt.res <- melt(dt.orig, "ID", patterns("^[ab]$", "^XX", "^YYY"), "obs", c("outcome", "XX", "YYY"))
setorder(dt.res, ID)[, obs := unname(c("1" = "a", "2" = "b")[obs])]

【讨论】：