Question

我有一个数据框，其中一列keys描述了所有其余列的格式。在下面的示例中，有2个这样的值列，但通常可能会有更多。

library(tidyverse)

dat = tribble(
  ~id, ~keys,    ~vals1,   ~vals2,
  1,    "A/B",   "1/2",   "11/12",
  3,    "C/D/E", "6/7/8", "16"
)

我想将这些列转换为嵌套数据帧的单列：在每一行中，值应在"/"上拆分，并形成数据帧的行，并从{{1 }}条目。

值列中的条目可能会被截断，在这种情况下，NA应该用于缺失值（例如，示例中的条目keys应该解释为"16"。）

以下代码针对这种特殊情况生成了所需的列：

"16/NA/NA"

我的问题是如何归纳到更大（且未知）的列数。另外，我对res = dat %>% mutate_at(vars(keys:last_col()), str_split, pattern = fixed("/")) %>% mutate(df = pmap(select(., keys:last_col()), ~ bind_rows(setNames(..2, ..1[1:length(..2)]), setNames(..3, ..1[1:length(..3)])))) res$df #> [[1]] #> # A tibble: 2 x 2 #> A B #> <chr> <chr> #> 1 1 2 #> 2 11 12 #> #> [[2]] #> # A tibble: 2 x 3 #> C D E #> <chr> <chr> <chr> #> 1 6 7 8 #> 2 16 <NA> <NA>的使用感觉很笨拙，我希望可以得到一些更优雅的东西。

我主要是在寻找tidyverse解决方案，但也欢迎使用其他方法。

更新

我应该强调，我正在寻找的输出是一个单个数据帧，其中列setNames（未更改）和id（嵌套数据列表）帧）。

（原始键/值列并不重要；可以将其删除。）

在上面的示例中，这是所需的结构：

df

Answer 1

在重塑后，这是另一个选择

library(dplyr)
library(tidyr)
library(purrr)
dat %>% 
  pivot_longer(matches("vals\\d+")) %>% 
  select(-id) %>% 
  pivot_wider(names_from = keys, values_from = value) %>% 
  select(-name) %>%
  split.default(seq_along(.)) %>%
  map(~ .x %>% 
           separate(names(.), into = str_split(names(.), fixed("/")) %>% 
                unlist, sep="[/]"))

Answer 2

对于每一行，您可以将最后3列转换为单个字符元素，其中列值由换行符分隔。然后，您实际上有了一个csv，但是带有/而不是逗号，因此您可以使用read.table或其他东西来读取它。我之所以使用data.table :: fread是因为它具有fill选项，但也许也可以通过read_table或read.table来实现这一点。

res <- 
  dat %>% 
    mutate(df =  apply(dat[-1], 1, function(x)
                    data.table::fread(paste(x, collapse = '\n'), 
                                      sep = '/', fill = TRUE)))

res$df

# [[1]]
#     A  B
# 1:  1  2
# 2: 11 12
# 
# [[2]]
#     C  D  E
# 1:  6  7  8
# 2: 16 NA NA

这是另一种选择。输出和想法基本相同，但未使用apply，因此不会创建临时（可能较大）的矩阵。但是代码不太清楚。

res <- 
  dat %>% 
    mutate(df =  lapply(do.call(paste, c(dat[-1], sep = '\n')),
                        data.table::fread, sep = '/', fill = TRUE))


res$df
# [[1]]
#     A  B
# 1:  1  2
# 2: 11 12
# 
# [[2]]
#     C  D  E
# 1:  6  7  8
# 2: 16 NA NA

您还可以如下使用split

split(dat[-1], dat[1]) %>% 
  map(~ fread(paste0(.x, collapse="\n"), sep="/", fill = TRUE))

# $`1`
#     A  B
# 1:  1  2
# 2: 11 12
# 
# $`3`
#     C  D  E
# 1:  6  7  8
# 2: 16 NA NA

Answer 3

这是我自己最初尝试的一种改进，该尝试至少适用于任意数量的列。

定义了一个小的实用函数后，

set_names_pad = function(x, y) {
  length(x) = length(y)
  setNames(x, y)
}

以下基于pmap的代码给出了所需的结果：

dat %>%
  mutate_at(vars(keys:last_col()), str_split, pattern = fixed("/"))  %>%
  mutate_at(vars(matches("val")), ~ map2(., keys, set_names_pad)) %>%
  mutate(df = pmap(select(., matches("val")), bind_rows))
#> # A tibble: 2 x 5
#>      id keys      vals1     vals2     df              
#>   <dbl> <list>    <list>    <list>    <list>          
#> 1     1 <chr [2]> <chr [2]> <chr [2]> <tibble [2 x 2]>
#> 2     3 <chr [3]> <chr [3]> <chr [3]> <tibble [2 x 3]>

当输入有很多行时，这似乎表现不错。这是与@IceCreamToucan的两个建议的比较：

# pmap solution
g = function(x) {
  x %>%
    mutate_at(vars(keys:last_col()), str_split, pattern = fixed("/"))  %>%
    mutate_at(vars(matches("val")), ~ map2(., keys, set_names_pad)) %>%
    mutate(df = pmap(select(., matches("val")), bind_rows))
}

# IceCreamToucan I
f1 = function(x) { 
  x %>% 
  mutate(df =  apply(.[-1], 1, function(x)
    data.table::fread(paste(x, collapse = '\n'), sep = '/', fill = TRUE)))
}

# IceCreamToucan II
f2 = function(x) {
  x %>%
    mutate(df = lapply(do.call(paste, c(.[-1], sep = '\n')),
                       data.table::fread, sep = '/', fill = TRUE))
}


bench::mark(f1(dat), f2(dat), g(dat), check = F)
#> # A tibble: 3 x 6
#>   expression      min   median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr> <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#> 1 f1(dat)      1.87ms   1.94ms     483.     1.93MB     9.38
#> 2 f2(dat)      1.59ms   1.66ms     573.    34.79KB    11.0 
#> 3 g(dat)       9.26ms   9.56ms      98.2   15.13KB    12.3

# Increase to 10,000 rows
dat2 = list(dat) %>% rep(5000) %>% bind_rows %>% mutate(id = row_number())

bench::mark(f1(dat2), f2(dat2), g(dat2), check = F)
#> Warning: Some expressions had a GC in every iteration; so filtering is
#> disabled.
#> # A tibble: 3 x 6
#>   expression      min   median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr> <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#> 1 f1(dat2)      5.58s    5.58s     0.179     164MB     2.87
#> 2 f2(dat2)      4.88s    4.88s     0.205     163MB     3.07
#> 3 g(dat2)    407.51ms 422.89ms     2.36      484KB     5.91

# Increase to 50,000 rows
dat3 = list(dat) %>% rep(25000) %>% bind_rows %>% mutate(id = row_number())

bench::mark(f1(dat3), f2(dat3), g(dat3), check = F)
#> Warning: Some expressions had a GC in every iteration; so filtering is
#> disabled.
#> # A tibble: 3 x 6
#>   expression      min   median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr> <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#> 1 f1(dat3)     30.56s   30.56s    0.0327   825.7MB     1.64
#> 2 f2(dat3)     26.84s   26.84s    0.0373   816.7MB     1.49
#> 3 g(dat3)       3.63s    3.63s    0.275      2.3MB     2.20

尽管如此，我仍然感觉可以使用tidyr的旋转功能更优雅地完成此操作。

创建尺寸可变的嵌套数据框

更新

3 个答案: