函数中的动态 select 表达式

Question

我正在尝试编写一个函数来转换此数据框

library(dplyr)
library(rlang)
library(purrr)

df <- data.frame(obj=c(1,1,2,2,3,3,3,4,4,4),
                 S1=rep(c("a","b"),length.out=10),PR1=rep(c(3,7),length.out=10),
                 S2=rep(c("c","d"),length.out=10),PR2=rep(c(7,3),length.out=10))

   obj S1 PR1 S2 PR2
1    1  a   3  c   7
2    1  b   7  d   3
3    2  a   3  c   7
4    2  b   7  d   3
5    3  a   3  c   7
6    3  b   7  d   3
7    3  a   3  c   7
8    4  b   7  d   3
9    4  a   3  c   7
10   4  b   7  d   3

进入这个数据框

df %>% {bind_rows(select(., obj, S = S1, PR = PR1),
              select(., obj, S = S2, PR = PR2))}
   obj S PR
1    1 a  3
2    1 b  7
3    2 a  3
4    2 b  7
5    3 a  3
6    3 b  7
7    3 a  3
8    4 b  7
9    4 a  3
10   4 b  7
11   1 c  7
12   1 d  3
13   2 c  7
14   2 d  3
15   3 c  7
16   3 d  3
17   3 c  7
18   4 d  3
19   4 c  7
20   4 d  3

但我希望该函数能够处理任意数量的列。因此，如果我有 S1、S2、S3、S4 或者如果有一个额外的类别，即 DS1、DS2，它也可以工作。理想情况下，该函数会将确定哪些列彼此堆叠的模式、每列的集合数、输出列的名称以及还应保留的任何变量的名称作为参数。

这是我对这个功能的尝试：

stack_col <- function(df, patterns, nums, cnames, keep){
  keep <- enquo(keep)
  build_exp <- function(x){
   paste0("!!sym(cnames[[", x, "]]) := paste0(patterns[[", x, "]],num)") %>% 
      parse_expr()
  }
  exps <- map(1:length(patterns), ~expr(!!build_exp(.)))

  sel_fun <- function(num){
    df %>% select(!!keep, 
                  !!!exps)
  }
  map(nums, sel_fun) %>% bind_rows()
}

我可以让 sel_fun 部分适用于像这样的固定数量的模式

patterns <- c("S", "PR")
cnames <- c("Species", "PR")
keep <- quo(obj)
sel_fun <- function(num){
df %>% select(!!keep,
!!sym(cnames[[1]]) := paste0(patterns[[1]], num),
!!sym(cnames[[2]]) := paste0(patterns[[2]], num))
}
sel_fun(1)

但是我试过的动态版本不工作，报错：

Error: `:=` can only be used within a quasiquoted argument

Answer 1

这解决了您的问题，但并未修复您的功能：

想法是在以特定模式开头的列上使用 gather 和 spread。因此，我创建了一个匹配列名的正则表达式，然后首先收集所有列名，提取组并使用 cnames 重命名组。最后传播需要分离新列。

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

patterns <- c("S", "PR")
cnames <- c("Species", "PR")
names(cnames) <- patterns 
complete_pattern <- str_c("^", str_c(patterns, collapse = "|^"))

df %>% 
  mutate(rownumber = 1:n()) %>%
  gather(new_variable, value, matches(complete_pattern)) %>% 
  mutate(group = str_extract(new_variable, complete_pattern), 
         group = str_replace_all(group, cnames),
         group_number = str_extract(new_variable, "\d+")) %>% 
  select(-new_variable) %>% 
  spread(group, value)

#    obj rownumber group_number PR Species
# 1    1         1            1  3       a
# 2    1         1            2  7       c
# 3    1         2            1  7       b
# 4    1         2            2  3       d
# 5    2         3            1  3       a
# 6    2         3            2  7       c
# 7    2         4            1  7       b
# 8    2         4            2  3       d
# 9    3         5            1  3       a
# 10   3         5            2  7       c
# 11   3         6            1  7       b
# 12   3         6            2  3       d
# 13   3         7            1  3       a
# 14   3         7            2  7       c
# 15   4         8            1  7       b
# 16   4         8            2  3       d
# 17   4         9            1  3       a
# 18   4         9            2  7       c
# 19   4        10            1  7       b
# 20   4        10            2  3       d

Answer 2

这是一个获取预期输出的函数。使用 map2、gather 循环遍历 'patterns' 和相应的新列名称 ('cnames') 到 'long' 格式，rename 'val' 列到传递给函数的 'cnames'，绑定列 (bind_cols) 和 select 感兴趣的列

stack_col <- function(dat, pat, cname, keep) {

    purrr::map2(pat, cname, ~ 
                    dat %>%
                       dplyr::select(keep, matches(.x)) %>%
                       tidyr::gather(key, val, matches(.x)) %>%
                       dplyr::select(-key) %>%
                       dplyr::rename(!! .y := val)) %>%
       dplyr::bind_cols(.) %>%
       dplyr::select(keep, cname) 



}

stack_col(df, patterns, cnames, 1)
#    obj Species PR
#1    1       a  3
#2    1       b  7
#3    2       a  3
#4    2       b  7
#5    3       a  3
#6    3       b  7
#7    3       a  3
#8    4       b  7
#9    4       a  3
#10   4       b  7
#11   1       c  7
#12   1       d  3
#13   2       c  7
#14   2       d  3
#15   3       c  7
#16   3       d  3
#17   3       c  7
#18   4       d  3
#19   4       c  7
#20   4       d  3

此外，可以使用 data.table::melt

进行多模式重塑

library(data.table)
melt(setDT(df), measure = patterns("^S\d+", "^PR\d+"), 
          value.name = c("Species", "PR"))[, variable := NULL][]

函数中的动态 select 表达式

Dynamic select expression in function

r

dplyr

nse

non-standard-evaluation