r - 从宽到长格式旋转，然后嵌套列

Question

我得到了多种格式的数据。每行都涉及当前表外部的变量，以及与该变量相关的可能值。我正在尝试:(1)转换为长格式，以及(2)嵌套转换值。
例子

library(tibble)

df_1 <-
  tribble(~key, ~values.male, ~values.female, ~values.red, ~values.green, ~value,
        "gender", 0.5, 0.5, NA, NA, NA,
        "age", NA, NA, NA, NA, "50",
        "color", NA, NA, TRUE, FALSE, NA,
        "time_of_day", NA, NA, NA, NA, "noon")

## # A tibble: 4 x 6
##   key         values.male values.female values.red values.green value
##   <chr>             <dbl>         <dbl> <lgl>      <lgl>        <chr>
## 1 gender              0.5           0.5 NA         NA           NA   
## 2 age                NA            NA   NA         NA           50   
## 3 color              NA            NA   TRUE       FALSE        NA   
## 4 time_of_day        NA            NA   NA         NA           noon 

在此示例中，我们看到 gender可以具有 female = 0.5和 male = 0.5。另一方面， age只能具有 50的单个值。从第3行开始，我们知道 color可以具有 red = TRUE和 green = FALSE以及 time_of_day = noon的值。
因此，数据透视表应采用以下嵌套形式:

my_pivoted_df <-
  structure(
    list(
      var_name = c("gender", "age", "color", "time_of_day"),
      vals = list(
        structure(
          list(
            level = c("male", "female"),
            value = c(0.5,
                      0.5)
          ),
          row.names = c(NA, -2L),
          class = c("tbl_df", "tbl", "data.frame")
        ),
        "50",
        structure(
          list(
            level = c("red", "green"),
            value = c(TRUE,
                      FALSE)
          ),
          row.names = c(NA, -2L),
          class = c("tbl_df", "tbl", "data.frame")
        ),
        "noon"
      )
    ),
    row.names = c(NA, -4L),
    class = c("tbl_df", "tbl",
              "data.frame")
  )


## # A tibble: 4 x 2
##   var_name    vals            
##   <chr>       <list>          
## 1 gender      <tibble [2 x 2]>
## 2 age         <chr [1]>       
## 3 color       <tibble [2 x 2]>
## 4 time_of_day <chr [1]>

我试图解决这个问题 df_1有两个问题。首先，当前列的命名很不方便。像 value这样的 header 并不理想，因为它们与 pivot_longer()的 ".value"机制冲突。其次，当 df_1具有多个选项(例如 values的“红色”和“绿色”)时， key具有 color(复数)，但是当 value仅具有一个选项(例如 key)时， age(单数)。
以下是受 this answer启发的我失败的代码。

library(tidyr)
library(dplyr)

df_1 %>%
  rename_with( ~ paste(.x, "single", sep = "."), .cols = value) %>% ## changed the header because otherwise it breaks
  pivot_longer(cols = starts_with("val"),
               names_to = c("whatevs", ".value"), names_sep = "\\.")


## # A tibble: 8 x 7
##   key         whatevs  male female red   green single
##   <chr>       <chr>   <dbl>  <dbl> <lgl> <lgl> <chr> 
## 1 gender      values    0.5    0.5 NA    NA    NA    
## 2 gender      value    NA     NA   NA    NA    NA    
## 3 age         values   NA     NA   NA    NA    NA    
## 4 age         value    NA     NA   NA    NA    50    
## 5 color       values   NA     NA   TRUE  FALSE NA    
## 6 color       value    NA     NA   NA    NA    NA    
## 7 time_of_day values   NA     NA   NA    NA    NA    
## 8 time_of_day value    NA     NA   NA    NA    noon  

我缺乏一些解决问题的技巧。

Answer 1

达到所需结果的整洁方法可能如下所示:

library(tibble)

df_1 <-
  tribble(~key, ~values.male, ~values.female, ~values.red, ~values.green, ~value,
          "gender", 0.5, 0.5, NA, NA, NA,
          "age", NA, NA, NA, NA, "50",
          "color", NA, NA, TRUE, FALSE, NA,
          "time_of_day", NA, NA, NA, NA, "noon")

library(tidyr)
library(dplyr)
library(purrr)

df_pivoted <- df_1 %>% 
  mutate(across(everything(), as.character)) %>% 
  pivot_longer(-key, names_to = "level", names_prefix = "^values\\.", values_drop_na = TRUE) %>% 
  group_by(key) %>% 
  nest() %>% 
  mutate(data = map(data, ~ if (all(.x$level == "value")) deframe(.x) else .x))
df_pivoted
#> # A tibble: 4 x 2
#> # Groups:   key [4]
#>   key         data            
#>   <chr>       <list>          
#> 1 gender      <tibble [2 × 2]>
#> 2 age         <chr [1]>       
#> 3 color       <tibble [2 × 2]>
#> 4 time_of_day <chr [1]>

编辑在您对所需结果的评论中进行了澄清之后，我们可以简单地摆脱map语句的结尾(这基本上是为了将没有级别的类别的小标题转换为向量)，并在嵌套到之前添加一个mutate语句对于不带 level的类别，将其替换为NA:

pivot_nest <- function(x) {
  mutate(x, across(everything(), as.character)) %>% 
    pivot_longer(-key, names_to = "level", names_prefix = "^values\\.", values_drop_na = TRUE) %>% 
    group_by(key) %>% 
    mutate(level = ifelse(all(level == "value"), NA_character_, level)) %>% 
    nest() 
}

df_pivoted <- df_1 %>% 
  pivot_nest()
df_pivoted
#> # A tibble: 4 x 2
#> # Groups:   key [4]
#>   key         data            
#>   <chr>       <list>          
#> 1 gender      <tibble [2 × 2]>
#> 2 age         <tibble [1 × 2]>
#> 3 color       <tibble [2 × 2]>
#> 4 time_of_day <tibble [1 × 2]>
df_pivoted$data
#> [[1]]
#> # A tibble: 2 x 2
#>   level value
#>   <chr> <chr>
#> 1 male  0.5  
#> 2 male  0.5  
#> 
#> [[2]]
#> # A tibble: 1 x 2
#>   level value
#>   <chr> <chr>
#> 1 <NA>  50   
#> 
#> [[3]]
#> # A tibble: 2 x 2
#>   level value
#>   <chr> <chr>
#> 1 red   TRUE 
#> 2 red   FALSE
#> 
#> [[4]]
#> # A tibble: 1 x 2
#>   level value
#>   <chr> <chr>
#> 1 <NA>  noon

df_2 <- tribble(~key, ~value, "age", "50", "income", "100000", "time_of_day", "noon")

df_pivoted2 <- df_2 %>% 
  pivot_nest()
df_pivoted2
#> # A tibble: 3 x 2
#> # Groups:   key [3]
#>   key         data            
#>   <chr>       <list>          
#> 1 age         <tibble [1 × 2]>
#> 2 income      <tibble [1 × 2]>
#> 3 time_of_day <tibble [1 × 2]>
df_pivoted2$data
#> [[1]]
#> # A tibble: 1 x 2
#>   level value
#>   <chr> <chr>
#> 1 <NA>  50   
#> 
#> [[2]]
#> # A tibble: 1 x 2
#>   level value 
#>   <chr> <chr> 
#> 1 <NA>  100000
#> 
#> [[3]]
#> # A tibble: 1 x 2
#>   level value
#>   <chr> <chr>
#> 1 <NA>  noon