在 dplyr 链中使用 if_else/summarize 添加数千列？答案

【问题标题】：Add thousands of columns using if_else/summarize in dplyr chain?在 dplyr 链中使用 if_else/summarize 添加数千列？
【发布时间】：2020-05-21 13:14:14
【问题描述】：

我的数据由各州的观察结果组成（即各州的快餐公司）。同一年对同一州组的多次观察是常见的。每行包含一个值（即新快餐连锁店的数量）。我将这些数据汇总到州组年中，然后需要创建一个二分指标，用于判断每个州组对是否在每年达到一定的特许经营门槛。之后，我需要将数据聚合到州-年级别，并创建一个二分指标来衡量是否有任何个州-组对在该年通过了阈值。

我正在使用 dplyr 来执行此操作，并且下面的代码可以完美运行。但是，我正在对不同的阈值（25 个特许经营权、50 个特许经营权等）进行硬编码，并且想要一个解决方案，我可以为任意数量的阈值创建变量——例如 25:1000 之间的所有数字。有没有一种直接且程序化的方式来做到这一点？我已经尝试过 dplyr 链中的循环，但在如何添加具有原则名称的新变量时遇到了困难（名称应包含阈值，以便在以后的代码中轻松引用）。感谢您的帮助！

注意：请随意编辑标题/问题以使其更清晰。

x <- data.frame("state" = c(rep("mi",12),
                            rep("tx",12)),
                "group" = c(rep("grp1",6),rep("grp2",6),
                            rep("grp3",6),rep("grp4",6)), 
                "year"  = c(rep(1990,3),rep(1991,3),rep(1992,3),rep(1993,3),
                            rep(1990,3),rep(1991,3),rep(1992,3),rep(1993,3)),
                "value" = c(seq(20,1200, by = 100),
                            seq(20,2400, by = 200)))

x_agg <- x %>%
  group_by(state, group, year) %>%
  summarise(value_tot = sum(value)) %>%
  mutate(val20   = ifelse(value_tot >= 20,   yes = 1, no = 0),
         val50   = ifelse(value_tot >= 50,   yes = 1, no = 0),
         val100  = ifelse(value_tot >= 100,  yes = 1, no = 0),
         val250  = ifelse(value_tot >= 250,  yes = 1, no = 0),
         val500  = ifelse(value_tot >= 500,  yes = 1, no = 0),
         val750  = ifelse(value_tot >= 750,  yes = 1, no = 0),
         val1000 = ifelse(value_tot >= 1000, yes = 1, no = 0)) %>%
  ungroup() %>%
  group_by(state, year) %>%
  summarise(val20   = as.numeric(any(val20 == 1)),
            val50   = as.numeric(any(val50 == 1)),
            val100  = as.numeric(any(val100 == 1)),
            val250  = as.numeric(any(val250 == 1)),
            val500  = as.numeric(any(val500 == 1)),
            val750  = as.numeric(any(val750 == 1)),
            val1000 = as.numeric(any(val1000 == 1)),) %>%
  ungroup()

【问题讨论】：

标签： r dplyr data-cleaning

【解决方案1】：

您可以使用lapply 创建函数列表并使用mutate_at 将它们全部应用。我从您提供的x 开始。只需更改 seq_val 即可获得您要测试的数字序列。

seq_val <- seq(1000, 10000, by = 1000)
val_funs <- lapply(seq_val, function(x) (function(a) as.integer(a >= x)))
names(val_funs) <- paste0("val", seq_val)

agg1 <- x %>%
  group_by(state, group, year) %>%
  summarise(value_tot = sum(value)) %>%
  ungroup() %>%
  mutate_at(
    "value_tot", 
    val_funs
  )

agg1 输出：

# A tibble: 8 x 14
  state group  year value_tot val1000 val2000 val3000 val4000 val5000 val6000
  <fct> <fct> <dbl>     <dbl>   <dbl>   <dbl>   <dbl>   <dbl>   <dbl>   <dbl>
1 mi    grp1   1990       360       0       0       0       0       0       0
2 mi    grp1   1991      1260       1       0       0       0       0       0
3 mi    grp2   1992      2160       1       1       0       0       0       0
4 mi    grp2   1993      3060       1       1       1       0       0       0
5 tx    grp3   1990       660       0       0       0       0       0       0
6 tx    grp3   1991      2460       1       1       0       0       0       0
7 tx    grp4   1992      4260       1       1       1       1       0       0
8 tx    grp4   1993      6060       1       1       1       1       1       1
# … with 4 more variables: val7000 <dbl>, val8000 <dbl>, val9000 <dbl>,
#   val10000 <dbl>

然后summarise_at 和any

agg1 %>%
  group_by(state, year) %>%
  summarise_at(
    vars(matches("val[^u]")),
    function(x) as.numeric(any(x == 1))
  )

输出：

# A tibble: 8 x 12
# Groups:   state [2]
  state  year val1000 val2000 val3000 val4000 val5000 val6000 val7000 val8000
  <fct> <dbl>   <dbl>   <dbl>   <dbl>   <dbl>   <dbl>   <dbl>   <dbl>   <dbl>
1 mi     1990       0       0       0       0       0       0       0       0
2 mi     1991       1       0       0       0       0       0       0       0
3 mi     1992       1       1       0       0       0       0       0       0
4 mi     1993       1       1       1       0       0       0       0       0
5 tx     1990       0       0       0       0       0       0       0       0
6 tx     1991       1       1       0       0       0       0       0       0
7 tx     1992       1       1       1       1       0       0       0       0
8 tx     1993       1       1       1       1       1       1       0       0
# … with 2 more variables: val9000 <dbl>, val10000 <dbl>

【讨论】：

如果您在第一个mutate_at 之前ungroup()，这可能会运行得更快。此外，您不需要ifelse，但可以使用as.integer(a >= x) 之类的东西。否则很好地使用mutate_at！
这太好了@ 谢谢 - 接受。快速且易于理解的解决方案。非常感谢您的帮助。我永远不会想到这种方法。

【解决方案2】：

这是适合您的一种方法。汇总数据后，我通过再次添加year 重新定义了组。然后，对于每个组，我想运行逻辑检查。每组中有一个特定的 value_tot 值。我使用标准值（即 20、50、100、250、500、750 和 1000）对此值进行了逻辑检查。返回的逻辑值将转换为数字并添加到具有标准值的数据框中。此时，foo 的每个单元格中都有一个数据框。我使用了 unnest 并创建了结果。它仍然是长格式。鉴于您想要宽格式数据，我最后使用了pivot_wider()。

library(tidyverse)

x %>%
group_by(state, group, year) %>%
summarise(value_tot = sum(value)) %>%
group_by(year, add = TRUE) %>% 
mutate(foo = list(tibble(check = sapply(c(20, 50, 100, 250, 500, 750, 1000),
                                        function(x) as.numeric(value_tot >= x)),
                         category = c(20, 50, 100, 250, 500, 750, 1000)))) %>% 
unnest(foo) %>% 
pivot_wider(id_cols = state:year, names_from = category, names_prefix = "val",
            values_from = "check")

  state group  year val20 val50 val100 val250 val500 val750 val1000
  <fct> <fct> <dbl> <dbl> <dbl>  <dbl>  <dbl>  <dbl>  <dbl>   <dbl>
1 mi    grp1   1990     1     1      1      1      0      0       0
2 mi    grp1   1991     1     1      1      1      1      1       1
3 mi    grp2   1992     1     1      1      1      1      1       1
4 mi    grp2   1993     1     1      1      1      1      1       1
5 tx    grp3   1990     1     1      1      1      1      0       0
6 tx    grp3   1991     1     1      1      1      1      1       1
7 tx    grp4   1992     1     1      1      1      1      1       1
8 tx    grp4   1993     1     1      1      1      1      1       1

【讨论】：

可能是findInterval可以用
谢谢！真的很有帮助。我从未使用过 pivot_wider，所以这很棒。我赞成但接受了最先出现的答案。
@akrun 直到今天晚上我才有时间考虑你的想法。现在我在想你的意思。 findInterval() 需要两个数值向量，对吧？所以一个向量是value_tot。另一个是包含 20、50、100 等的。值
@akrun 我会在这个周末进一步考虑这个问题。现在去睡觉了。希望你在这里努力工作。 :)
@akrun 我刚刚使用了findInterval()。我今天在想，据我所知， findInterval() 确实有效。但它可能需要更多的编码。正如我上次提到的，我可以返回一个整数。例如，我想我可以使用 seq() 中的这个整数创建一个 1 的序列。但问题是我想法中的 sapply() 实际上是在做同样的事情。它可能在某种程度上节省了打字。你能想到任何其他方法来利用 findIntervals() 吗？如果有任何想法，请告诉我。

【解决方案3】：

我想在这里尝试在多张桌子上使用lapply 和join。在treshold 中定义列。

library("dplyr")

x <- data.frame("state" = c(rep("mi",12),
                            rep("tx",12)),
                "group" = c(rep("grp1",6),rep("grp2",6),
                            rep("grp3",6),rep("grp4",6)), 
                "year"  = c(rep(1990,3),rep(1991,3),rep(1992,3),rep(1993,3),
                            rep(1990,3),rep(1991,3),rep(1992,3),rep(1993,3)),
                "value" = c(seq(20,1200, by = 100),
                            seq(20,2400, by = 200)))

treshold <- c(20, 50, 100, 250, 500, 750, 1000)

lapply(as.list(treshold), function(tres){

  name <- paste0("val", tres)

  x %>% 
    group_by(state, group, year) %>% 
    summarise(value_tot = sum(value)) %>%
    mutate(!!name := as.integer(value_tot >= tres)) %>% 
    ungroup() %>% 
    group_by(state, year) %>%
    summarise(!!name := as.numeric(any(!!sym(name) == 1)))

}) %>% Reduce(function(d1, d2) full_join(d1, d2, by = c("state", "year")), .)

【讨论】：

不错的答案！不需要ungroup，然后是group_by，尽管您可以将ungroup 移动一行（在mutate 之前）。我想知道你是否可以只绑定新列，而不是做一个更昂贵的full_join。
我同意group_by - 我刚刚从原始示例中复制了它，但是 - 正如你所说 - 这是不必要的。绑定的问题是它重复所有列。您可能可以尝试这样做（例如，对list 的第一个元素进行例外处理以仅将这两列保留一次）。如果数据很大，这可能是值得的。

【解决方案4】：

valueExceeds <- function(df, n){
    variableName <- paste0("val", n)
    df %>%
        group_by(state, group, year) %>%
        summarise(value_tot = sum(value)) %>%
        mutate(!!variableName := as.integer(value_tot >= n))
}

x %>%
    valueExceeds(20)

输出这个

  state group  year value_tot val20
  <fct> <fct> <dbl>     <dbl> <int>
1 mi    grp1   1990       360     1
2 mi    grp1   1991      1260     1
3 mi    grp2   1992      2160     1
4 mi    grp2   1993      3060     1
5 tx    grp3   1990       660     1
6 tx    grp3   1991      2460     1
7 tx    grp4   1992      4260     1
8 tx    grp4   1993      6060     1

【讨论】：