4

通常我需要spread多个值列，就像在这个问题中一样。但是我经常这样做，以至于我希望能够编写一个执行此操作的函数。

例如，给定数据：

set.seed(42)
dat <- data_frame(id = rep(1:2,each = 2),
                  grp = rep(letters[1:2],times = 2),
                  avg = rnorm(4),
                  sd = runif(4))
> dat
# A tibble: 4 x 4
     id   grp        avg        sd
  <int> <chr>      <dbl>     <dbl>
1     1     a  1.3709584 0.6569923
2     1     b -0.5646982 0.7050648
3     2     a  0.3631284 0.4577418
4     2     b  0.6328626 0.7191123

我想创建一个返回如下内容的函数：

# A tibble: 2 x 5
     id     a_avg      b_avg      a_sd      b_sd
  <int>     <dbl>      <dbl>     <dbl>     <dbl>
1     1 1.3709584 -0.5646982 0.6569923 0.7050648
2     2 0.3631284  0.6328626 0.4577418 0.7191123

我怎样才能做到这一点？

4

3 回答 3

7

我们将返回链接到的问题中提供的答案，但目前让我们从更天真的方法开始。

一个想法是分别对spread每个值列，然后加入结果，即

library(dplyr)
library(tidyr)
library(tibble)

dat_avg <- dat %>% 
    select(-sd) %>%
    spread(key = grp,value = avg) %>%
    rename(a_avg = a,
           b_avg = b)

dat_sd <- dat %>% 
    select(-avg) %>%
    spread(key = grp,value = sd) %>%
    rename(a_sd = a,
           b_sd = b)

> full_join(dat_avg,
          dat_sd,
          by = 'id')

# A tibble: 2 x 5
     id     a_avg      b_avg      a_sd      b_sd
  <int>     <dbl>      <dbl>     <dbl>     <dbl>
1     1 1.3709584 -0.5646982 0.6569923 0.7050648
2     2 0.3631284  0.6328626 0.4577418 0.7191123

（我使用了一个full_join以防我们遇到并非所有连接列的所有组合都出现在所有组合中的情况。）

让我们从一个功能类似spread但允许您将key和value列作为字符传递的函数开始：

spread_chr <- function(data, key_col, value_cols, fill = NA, 
                       convert = FALSE,drop = TRUE,sep = NULL){
    n_val <- length(value_cols)
    result <- vector(mode = "list", length = n_val)
    id_cols <- setdiff(names(data), c(key_col,value_cols))

    for (i in seq_along(result)){
        result[[i]] <- spread(data = data[,c(id_cols,key_col,value_cols[i]),drop = FALSE],
                              key = !!key_col,
                              value = !!value_cols[i],
                              fill = fill,
                              convert = convert,
                              drop = drop,
                              sep = paste0(sep,value_cols[i],sep))
    }

    result %>%
        purrr::reduce(.f = full_join, by = id_cols)
}

> dat %>%
  spread_chr(key_col = "grp",
             value_cols = c("avg","sd"),
             sep = "_")

# A tibble: 2 x 5
     id grp_avg_a  grp_avg_b  grp_sd_a  grp_sd_b
  <int>     <dbl>      <dbl>     <dbl>     <dbl>
1     1 1.3709584 -0.5646982 0.6569923 0.7050648
2     2 0.3631284  0.6328626 0.4577418 0.7191123

这里的关键思想是取消引用参数key_col并value_cols[i]使用!!运算符，并使用sep参数 inspread来控制结果值列名称。

如果我们想将此函数转换为接受键和值列的不带引号的参数，我们可以像这样修改它：

spread_nq <- function(data, key_col,..., fill = NA, 
                      convert = FALSE, drop = TRUE, sep = NULL){
    val_quos <- rlang::quos(...)
    key_quo <- rlang::enquo(key_col)
    value_cols <- unname(tidyselect::vars_select(names(data),!!!val_quos))
    key_col <- unname(tidyselect::vars_select(names(data),!!key_quo))

    n_val <- length(value_cols)
    result <- vector(mode = "list",length = n_val)
    id_cols <- setdiff(names(data),c(key_col,value_cols))

    for (i in seq_along(result)){
        result[[i]] <- spread(data = data[,c(id_cols,key_col,value_cols[i]),drop = FALSE],
                              key = !!key_col,
                              value = !!value_cols[i],
                              fill = fill,
                              convert = convert,
                              drop = drop,
                              sep = paste0(sep,value_cols[i],sep))
    }

    result %>%
        purrr::reduce(.f = full_join,by = id_cols)
}

> dat %>%
  spread_nq(key_col = grp,avg,sd,sep = "_")

# A tibble: 2 x 5
     id grp_avg_a  grp_avg_b  grp_sd_a  grp_sd_b
  <int>     <dbl>      <dbl>     <dbl>     <dbl>
1     1 1.3709584 -0.5646982 0.6569923 0.7050648
2     2 0.3631284  0.6328626 0.4577418 0.7191123

这里的变化是我们使用 捕获未引用的参数，rlang::quos然后rlang::enquo使用 简单地将它们转换回字符tidyselect::vars_select。

回到链接问题中使用gather,unite和序列的解决方案spread，我们可以使用我们学到的知识来制作这样的函数：

spread_nt <- function(data,key_col,...,fill = NA,
                      convert = TRUE,drop = TRUE,sep = "_"){
  key_quo <- rlang::enquo(key_col)
  val_quos <- rlang::quos(...)
  value_cols <- unname(tidyselect::vars_select(names(data),!!!val_quos))
  key_col <- unname(tidyselect::vars_select(names(data),!!key_quo))

  data %>%
    gather(key = ..var..,value = ..val..,!!!val_quos) %>%
    unite(col = ..grp..,c(key_col,"..var.."),sep = sep) %>%
    spread(key = ..grp..,value = ..val..,fill = fill,
           convert = convert,drop = drop,sep = NULL)
}

> dat %>%
  spread_nt(key_col = grp,avg,sd,sep = "_")

# A tibble: 2 x 5
     id     a_avg      a_sd      b_avg      b_sd
* <int>     <dbl>     <dbl>      <dbl>     <dbl>
1     1 1.3709584 0.6569923 -0.5646982 0.7050648
2     2 0.3631284 0.4577418  0.6328626 0.7191123

这依赖于上一个示例中来自rlang的相同技术。我们..var..为中间变量使用了一些不寻常的名称，以减少与数据框中现有列发生名称冲突的可能性。

此外，我们使用sep参数 inunite来控制生成的列名，所以在这种情况下，当spread我们强制sep = NULL.

于 2017-09-02T01:58:40.010 回答
3

传播操作也可以通过取消嵌套正确重新格式化的表来完成，这是使用的替代方法tidyverse：

# helper function that returns an horizontal one lined named tibble wrapped into a list
lhframe <- function(x,nms) list(setNames(as_tibble(t(x)),nms))
dat %>% group_by(id) %>%
  summarize(avg = lhframe(avg,grp),
            sd  = lhframe(sd,grp)) %>%
  unnest(.sep="_")

# # A tibble: 2 x 5
#      id      avg_a     avg_b      sd_a      sd_b
#   <int>      <dbl>     <dbl>     <dbl>     <dbl>
# 1     1 -1.7631631 0.4600974 0.7595443 0.5664884
# 2     2 -0.6399949 0.4554501 0.8496897 0.1894739

不幸的是，以下方法不起作用：

dat %>% group_by(id) %>%
  summarize_at(vars(avg,sd),lhframe,grp) %>%
  unnest(.sep="_")
于 2018-03-27T12:22:19.580 回答
2

从 tidyr 版本 1.0.0 开始

tidyr::pivot_wider(data = dat, id_cols = id, names_from = grp, values_from = avg:sd) 
# # A tibble: 2 x 5
#      id avg_a  avg_b  sd_a  sd_b
#   <int> <dbl>  <dbl> <dbl> <dbl>
# 1     1 1.37  -0.565 0.657 0.705
# 2     2 0.363  0.633 0.458 0.719
于 2019-10-17T05:26:38.563 回答