r - 在每个组的嵌套数据中通过 across 应用简单函数

Question

背景

给定nested data , 我想使用 across 应用一个简单的函数在任意选择的列上。使用 across 我想遍历传递给函数的一个参数的列的选择，并保持第二个参数不变。

---

例子

# Using across within nested data frame

# Gapminder data from gapminder package
library("tidyverse")
data("gapminder", package = "gapminder")

# Sample function
sample_function <- function(.data, var_a, var_b) {
    var_a <- enquo(var_a)
    var_b <- enquo(var_b)
    .data %>%
        mutate(some_res = log(!!var_a) + !!var_b) %>%
        pull(some_res)
}


# Basic example, not working
gapminder %>%
    group_by(country, continent) %>%
    nest() %>%
    mutate(sample_res = map(
        .x = data,
        .f = across(
            .cols = vars(year, lifeExp, pop),
            .fns = ~ sample_function(var_a = .x),
            var_b = gdpPercap
        )
    )) %>%
    unnest(sample_res)

示例失败并出现以下错误:

Error: Problem with mutate() input sample_res. x Must subset columns with a valid subscript vector. x Subscript has the wrong type quosures. ℹ It must be numeric or character. ℹ Input sample_res is map(...). ℹ The error occured in group 1: country = "Afghanistan", continent = "Asia". Run rlang::last_error() to see where the error occurred.

期望的结果

我可以遍历选定的列，始终在 var_a 中传递不同的参数。在这种情况下，值反射(reflect)了 year、lifeExp 和 gdpPercap 变量。

gapminder %>%
    group_by(country, continent) %>%
    nest() %>%
    mutate(
        res_year = map(.x = data, 
                       .f = sample_function, var_a = year, var_b = gdpPercap),
        res_lifeExp = map(.x = data, 
                          .f = sample_function, var_a = lifeExp, 
                          var_b = gdpPercap),
        res_pop = map(.x = data, 
                      .f = sample_function, var_a = pop, var_b = gdpPercap)
    )

---

寻求解决方案

在期望的结果中获得的解决方案是相当不切实际且容易出错的，因为强制为每个变量创建新行。我想找到使用 across 和 map 的组合，这样我就可以通过向 across 添加变量来运行映射函数的不同变体。

Answer 1

最终更新(使用nest_by & across)

受@Brunos 回答的启发，我修改了使用 nest_by/rowwise 而不是 map 的方法(我猜，新推荐的处理嵌套 tibbles 的方法)。

可以使用 nest_by 轻松重现我的原始答案的结果:

gapminder %>%
  nest_by(country, continent) %>%
  mutate(sample_res = list(transmute(data,
                                     across(c(year, lifeExp, pop),
                                            ~ sample_function(data, var_a = .x, var_b = gdpPercap))
  ))
  ) 

但是，它返回一个 包含tibble 的列表列。如果输出是法线向量，我们只需删除 sample_res = list() 即可将新列添加到您现有的 tibble 中。但是，在此示例中，每个新列的输出都是一个包含向量的列表列。我未能在对 mutate(across(...)) 的一次调用中生成此输出。

尽管可以使用 unnest 然后再次调用 summarise(across(...)) 来完成工作。

gapminder %>%
  nest_by(country, continent) %>%
  mutate(sample_res = list(transmute(data,
                             across(c(year, lifeExp, pop),
                                    ~ sample_function(data, var_a = .x, var_b = gdpPercap))
                      ))
         ) %>% 
  unnest(cols = sample_res) %>%
  summarise(across(c(year, lifeExp, pop), list, .names = "res_{col}"))

原始答案(使用group_by、nest、map & across)

您在 across 调用中错误指定了 sample_function。应该是

function(x) sample_function(.x, var_a = x, var_b = gdpPercap)

代替

~ sample_function(var_a = .x),
                var_b = gdpPercap

因为你嵌套了 map 和 mutate(across(...))，我更喜欢至少有一个“正常的”匿名函数而不是 lamda ~ 符号。否则，事情会因为两个 .x 而变得困惑。

进一步的 across 应该在它自己单独的 mutate 中调用。

这应该有效:

library("tidyverse")
data("gapminder", package = "gapminder")

# Sample function
sample_function <- function(.data, var_a, var_b) {
  var_a <- enquo(var_a)
  var_b <- enquo(var_b)

  .data %>%
    mutate(some_res = log(!!var_a) + !!var_b) %>%
    pull(some_res)
}

gapminder %>%
  group_by(country, continent) %>%
  nest() %>%  
  mutate(sample_res = map(
    data,
    ~ mutate(.x, across(c(year, lifeExp, pop),
                       function(x) { 
                         sample_function(.x, var_a = x, var_b = gdpPercap)
                        }
                       )
    )
   )
  )
#> # A tibble: 142 x 4
#> # Groups:   country, continent [142]
#>    country     continent data              sample_res       
#>    <fct>       <fct>     <list>            <list>           
#>  1 Afghanistan Asia      <tibble [12 × 4]> <tibble [12 × 4]>
#>  2 Albania     Europe    <tibble [12 × 4]> <tibble [12 × 4]>
#>  3 Algeria     Africa    <tibble [12 × 4]> <tibble [12 × 4]>
#>  4 Angola      Africa    <tibble [12 × 4]> <tibble [12 × 4]>
#>  5 Argentina   Americas  <tibble [12 × 4]> <tibble [12 × 4]>
#>  6 Australia   Oceania   <tibble [12 × 4]> <tibble [12 × 4]>
#>  7 Austria     Europe    <tibble [12 × 4]> <tibble [12 × 4]>
#>  8 Bahrain     Asia      <tibble [12 × 4]> <tibble [12 × 4]>
#>  9 Bangladesh  Asia      <tibble [12 × 4]> <tibble [12 × 4]>
#> 10 Belgium     Europe    <tibble [12 × 4]> <tibble [12 × 4]>
#> # … with 132 more rows

^{由 reprex package 创建于 2020-06-03 (v0.3.0)}

当使用带有自定义函数的 map 来循环列表列中的 tibbles 时，在循环之外构建第一个版本非常有帮助。

test_dat <- gapminder %>%
  nest_by(country, continent) 

test_dat$data[[1]] %>% 
  mutate(across(
    c(year, lifeExp, pop),
    ~ sample_function(test_dat$data[[1]], var_a = .x, var_b = gdpPercap)
    )
    )

一旦成功，最后一步就是用 .x 替换您要循环的对象。

另一种方法(原始答案的一部分)

另一种方法是重写您原来的 sample_function 并在您的 mutate 调用中包含 across 。我们可以让它采用变量名称的字符串向量，这些变量名称将传递给 across。我可能更喜欢这种方法，因为它更灵活。现在您可以有另一个列表列，其中包含不同变量名称的不同数据子集，并使用 map2 遍历它们和您的数据列。

library("tidyverse")
data("gapminder", package = "gapminder")

sample_function2 <- function(.data, .vars, var_b) {
  .vars <- syms(.vars)
  var_b <- enquo(var_b)

  .data %>%
    mutate(across(c(!!!.vars), function(y) log(y) + !!var_b))
}


gapminder %>%
  group_by(country, continent) %>%
  nest() %>% 
  mutate(sample_res = map(
    data,
    ~ sample_function2(.x,
                       .vars = c("year", "lifeExp", "pop"),
                       var_b = gdpPercap)
  )
  )

#> # A tibble: 142 x 4
#> # Groups:   country, continent [142]
#>    country     continent data              sample_res       
#>    <fct>       <fct>     <list>            <list>           
#>  1 Afghanistan Asia      <tibble [12 × 4]> <tibble [12 × 4]>
#>  2 Albania     Europe    <tibble [12 × 4]> <tibble [12 × 4]>
#>  3 Algeria     Africa    <tibble [12 × 4]> <tibble [12 × 4]>
#>  4 Angola      Africa    <tibble [12 × 4]> <tibble [12 × 4]>
#>  5 Argentina   Americas  <tibble [12 × 4]> <tibble [12 × 4]>
#>  6 Australia   Oceania   <tibble [12 × 4]> <tibble [12 × 4]>
#>  7 Austria     Europe    <tibble [12 × 4]> <tibble [12 × 4]>
#>  8 Bahrain     Asia      <tibble [12 × 4]> <tibble [12 × 4]>
#>  9 Bangladesh  Asia      <tibble [12 × 4]> <tibble [12 × 4]>
#> 10 Belgium     Europe    <tibble [12 × 4]> <tibble [12 × 4]>
#> # … with 132 more rows

^{由 reprex package 创建于 2020-06-04 (v0.3.0)}

添加(原始答案)

正如@Bruno 指出的那样，上述方法不是 OP 指定的格式，这里是基于我上面的第二种方法的替代解决方案，它应该会产生所需的输出。

library("tidyverse")
data("gapminder", package = "gapminder")

sample_function2 <- function(.data, .vars, var_b) {
  .vars <- syms(.vars)
  var_b <- enquo(var_b)

  .data %>%
    transmute(across(c(!!!.vars), function(y) log(y) + !!var_b)) %>% 
    unlist()

}

my_vars <- c("year", "lifeExp", "pop")

gapminder %>%
  group_by(country, continent) %>%
  nest() %>% 
  crossing(vars = my_vars) %>% 
  mutate(sample_res = map2(
    data,
    vars, 
    ~ sample_function2(.x,
                       .vars = .y,
                       var_b = gdpPercap)
  )
  ) %>% 
  pivot_wider(names_from = vars,
              names_prefix = "res_",
              values_from = sample_res) 

#> # A tibble: 142 x 6
#>    country     continent data              res_lifeExp res_pop    res_year  
#>    <fct>       <fct>     <list>            <list>      <list>     <list>    
#>  1 Afghanistan Asia      <tibble [12 × 4]> <dbl [12]>  <dbl [12]> <dbl [12]>
#>  2 Albania     Europe    <tibble [12 × 4]> <dbl [12]>  <dbl [12]> <dbl [12]>
#>  3 Algeria     Africa    <tibble [12 × 4]> <dbl [12]>  <dbl [12]> <dbl [12]>
#>  4 Angola      Africa    <tibble [12 × 4]> <dbl [12]>  <dbl [12]> <dbl [12]>
#>  5 Argentina   Americas  <tibble [12 × 4]> <dbl [12]>  <dbl [12]> <dbl [12]>
#>  6 Australia   Oceania   <tibble [12 × 4]> <dbl [12]>  <dbl [12]> <dbl [12]>
#>  7 Austria     Europe    <tibble [12 × 4]> <dbl [12]>  <dbl [12]> <dbl [12]>
#>  8 Bahrain     Asia      <tibble [12 × 4]> <dbl [12]>  <dbl [12]> <dbl [12]>
#>  9 Bangladesh  Asia      <tibble [12 × 4]> <dbl [12]>  <dbl [12]> <dbl [12]>
#> 10 Belgium     Europe    <tibble [12 × 4]> <dbl [12]>  <dbl [12]> <dbl [12]>
#> # … with 132 more rows

^{由 reprex package 创建于 2020-06-04 (v0.3.0)}