功能中的动态选择表达式

时间:2018-08-29 16:53:48

标签: r dplyr nse non-standard-evaluation

我正在尝试编写一个将转换此数据帧的函数

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

2 个答案:

答案 0 :(得分:2)

这里是获取期望输出的函数。使用map2gather将“模式”和相应的新列名(“ cnames”)循环成“长”格式,rename将“ val”列循环到“ cnames”传递给函数,绑定列(bind_colsselect感兴趣的列

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][]

答案 1 :(得分:1)

这解决了您的问题,尽管它不能修复您的功能:

想法是在以特定模式开头的列上使用gatherspread。因此,我创建了一个与列名称匹配的正则表达式,然后首先收集所有列名称,提取组并使用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