从两个其他列的范围信息创建并填充新列。

Question

我有以下数据：

df <- data.frame(group  = c(1, 1, 1, 2, 2, 2),
                 start  = c(2, 2, 2, 7, 7, 7),
                 stop   = c(4, 7, 8, 7, 8, 9),
                 unstop = c(5, 7, 10, 7, 9, 10))

我现在想做以下事情：

• 创建名为 "week_1"，"week_2"，...，"week_10"，"week_n" 的新列。
• 对于 FIRST ROW 中的每个组，检查该行在哪些周内“活动”，例如它从第 2 周开始，在第 4 周停止，则该行在第 2、3、4 周处于活动状态。我现在希望在相应的周列中填充 1。
• 对于除了最后一行以外的所有其他行，我执行相同的检查，但现在是基于该行的 unstop 值和下一行的 stop 值进行填充。
• 对于每个组的 LAST ROW，我执行相同的检查，但现在是基于从 unstop 到 10（在我的情况下是最后一周）的范围进行填充。

我有一种理论上的方法。问题是我的实际数据有 80k 行（由 60k 个组成），我需要创建大约 200 个这样的周列。即使仅对 10 行进行过滤，下面的代码也需要大约 30 秒。

因此，我正在寻找更优雅/更智能/更快速的解决方案。

预期结果：

# A tibble: 6 × 14
# Groups:   group [2]
  group start  stop unstop week_1 week_2 week_3 week_4 week_5 week_6 week_7 week_8 week_9 week_10
  <dbl> <dbl> <dbl>  <dbl>  <int>  <int>  <int>  <int>  <int>  <int>  <int>  <int>  <int>   <int>
1     1     2     4      5      0      1      1      1      0      0      0      0      0       0
2     1     2     7      7      0      0      0      0      0      0      1      1      0       0
3     1     2     8     10      0      0      0      0      0      0      0      0      0       1
4     2     7     7      7      0      0      0      0      0      0      1      0      0       0
5     2     7     8      9      0      0      0      0      0      0      0      1      1       0
6     2     7     9     10      0      0      0      0      0      0      0      0      0       1

以下是我通常会采用的方法（当然不是手动定义每个行号）。除此之外，这段代码也是错误的，并且不能给出预期的0/1值。它还会抛出许多警告。最后，即使是针对这小测试数据，该代码也需要运行几秒钟。而对于我的 80k/200 列数据集，则需要运行一个月。

add_weeks <- as_tibble(as.list(setNames(rep(0L, 10),
                                        paste0("week_", 1:10))))

df |> 
  bind_cols(add_weeks) |> 
  group_by(group) |> 
  mutate(across(num_range("week_", 1:10),
                ~ if_else(row_number() == 1 & str_extract(cur_column(), "\\d+$") %in% start:stop,
                          1L,
                          .)),
         across(num_range("week_", 1:10),
                ~ if_else(row_number() == 2 & str_extract(cur_column(), "\\d+$") %in% unstop:lead(stop),
                          1L,
                          .)),
         across(num_range("week_", 1:10),
                ~ if_else(row_number() == 3 & str_extract(cur_column(), "\\d+$") %in% unstop:10,
                          1L,
                          .)))

- deschen

---

你应该说明你计划如何分析这个问题。如果你打算使用生存分析进行时间变化协变量分析，最好使用长格式进行分析。 - IRTFM

我会创建一个带有名称列的矩阵，并分配行和列索引。然后，您可以将其作为矩阵附加或转换为数据框。 - IRTFM

有什么提示如何做到这一点吗？我不确定我能否跟上。 - deschen

快要完成了。需要知道所有组是否都有恰好3行？ - IRTFM

我认为我的贡献可以修改以适应各种逻辑。加速是由于按字符值进行索引。 - IRTFM

Answer 1

现在测试代码。实施评论中描述的策略：

我会创建一个以名称列为主的矩阵，并分配行和列索引。然后，您可以将其作为矩阵附加或转换为数据框。

Mat <- matrix(0, nrow(df), 10) # 200 for real case
maxwk <- 10
colnames(Mat) <- paste0("week", 1:maxwk)

# Add extra column that marks condition 
# If there are always exactly 3 row per group just rep(1:3, ngrps)

# Need to define a value for cond that identifies the three possibilities:

df$cond <- rep(1:3, length=nrow(df))  # assume all groups have exactly 3:

for ( r in 1:nrow(df) ) {
          # for first row in group
  if( df$cond[r] == 1){
     Idx <-  paste0("week", df$start[r]:df$stop[r] ) #start:stop
     Mat[r, Idx] <- 1; next}
          # second
  if( df$cond[r] == 2){ 
     Idx <-  paste0("week" , df$stop[r]:df$unstop[r] )#  stop:unstop
     Mat[r, Idx] <- 1; next}
          # third
  if( df$cond[r] == 3){
    Idx  <- paste0("week", df$unstop[r]:maxwk )    # unstop:max
    Mat[r, Idx] <- 1; next}
  }

df
  group start stop unstop cond
1     1     2    4      5    1
2     1     2    7      7    2
3     1     2    8     10    3
4     2     7    6      7    1
5     2     7    8      9    2
6     2     7    9     10    3
> Mat
     week1 week2 week3 week4 week5 week6 week7 week8 week9 week10
[1,]     0     1     1     1     0     0     0     0     0      0
[2,]     0     0     0     0     0     0     1     0     0      0
[3,]     0     0     0     0     0     0     0     0     0      1
[4,]     0     0     0     0     0     1     1     0     0      0
[5,]     0     0     0     0     0     0     0     1     1      0
[6,]     0     0     0     0     0     0     0     0     0      1

您可以使用cbind进行合并。

可能存在性能改进的可能。可以使用switch(cond, ...)来分派到正确的逻辑，而不是使用if( cond == .){ ., next}方法。这应该比使用ifelse或if_else的代码要快得多。如果您想看看如何实现这一点，请用一个勾号表示您支持这种策略，我将花时间添加备选代码。

在为100周最大值设置两种方法后运行了基准测试。*警告来自问题中的代码：

> perf_results <- microbenchmark(
+     first.method    = do_first(df), sec.method=do_second(df), times=10)
There were 50 or more warnings (use warnings() to see the first 50)
> perf_results
Unit: microseconds
         expr         min        lq         mean       median          uq        max neval
 first.method 4385001.123 4416568.8 4581549.9624 4450691.5455 4615753.753 5350416.80    10
   sec.method     146.432     149.6     181.6137     188.2125     193.307     243.47    10

我想尝试使用 switch 方法来选择适当的算法以提高性能。这确实让我感到惊讶。 switch 函数类似于 Pascal 和许多其他语言中的 case 函数。它有两种形式，其行为取决于第一个参数 EXPR 是数字还是字符。在这里，选择“分发”版本，因为“cond”列是数字。

do_third= function(df){ Mat <- matrix(0, nrow(df), 100) # 200 for real case
maxwk <- 100
colnames(Mat) <- paste0("week", 1:maxwk)
df$cond <- rep(1:3, length=nrow(df))  # assume all groups have exactly 3: 
for( r in 1:nrow(df)) { switch( df[r,"cond"],      
         { # for first row in each group of 3
     Idx <-  paste0("week", df$start[r]:df$stop[r] ) #start:stop
     Mat[r, Idx] <- 1 }, 
          
          { # second row in group
     Idx <-  paste0("week" , df$stop[r]:df$unstop[r] )#  stop:unstop
     Mat[r, Idx] <- 1 },
          
          {# third
     Idx  <- paste0("week", df$unstop[r]:maxwk )    # unstop:max
     Mat[r, Idx] <- 1 } ) }
   }

新的微基准测试：

perf_results
Unit: nanoseconds
         expr        min         lq         mean     median         uq        max neval cld
 first.method 4304901359 4351893534 4387626725.8 4372151785 4416247096 4543314742    10   b
   sec.method     162803     173855    2588492.1     215309     216878   24081195    10  a 
   third.meth         34         53        610.6        877        940        963    10  a 

- IRTFM

---

谢谢你的回复。我有点困惑，你实际上在哪里使用了 switch 函数？你使用了 select，但我在基本 R 中找不到任何关于它的帮助。 - deschen

我认为select是从tidyverse中来的。我在一台机器上使用了switch，然后在第二台机器上交换它们。我会尝试清理这个混乱。 - IRTFM

select was definitely not the correct tidyverse equivalent. You could try case_when - IRTFM

此外，有趣的是，虽然这种矩阵方法非常快，但在我的实际情况下，使用我的“separate_rows”方法运行代码的总运行时间略长或者与之相当。我认为这是因为你的解决方案对于创建所有周列非常快，但是我需要进行几个聚合步骤。而使用 separate_rows 给我提供了一个小的长格式数据集，可以进行更快的聚合。我没有测试速度瓶颈的确切位置，但发现这很有趣。 - deschen

在这方面，你的第一种方法总体上对我来说似乎比使用第三种方法的方法更快。 - deschen

我没有预料到switch方法会快那么多。我以为它可能只会快10-20%。我从上一个方法中删除了下一个语句。它们应该是不需要的。 - IRTFM

Answer 2

FWIW，我会发布自己的解决方案。 显然，根据某些条件向60k数据框添加200个列非常缓慢。 因此，我所做的是：

• 使用str_c添加一个包含有关周数信息的chr列。
• 创建一个较小的数据集，其中仅具有分组变量和此新信息。
• 然后在此week_info上使用separate_rows以获取长格式数据集。
• 然后使用pivot_wider并将此信息与原始数据集相结合。

请注意，这种方法之所以有效，是因为我在最初的帖子中没有提到我实际上想要总结每个组的周信息。 因此，最终我想要每个组一行。 为了使问题简单化，我没有将其添加到我的问题中。

话虽如此，@IRTFM的解决方案仍然快了3倍。

df2 <- df |>
  group_by(group) |> 
  mutate(lead_stop = lead(stop, default = 0),
         n_rows = n(),
         row_number = row_number()) |> 
  ungroup() |> 
  rowwise() |> 
  mutate(split_weeks = case_when(n_rows == 1 & row_number == 1 ~ str_c(start:stop, collapse = ","),
                                 n_rows  > 1 & row_number == 1 ~ str_c(c(start:stop, unstop:lead_stop), collapse = ","),
                                 row_number == n_rows          ~ str_c(unstop:10, collapse = ","),
                                 TRUE                          ~ str_c(unstop:lead_stop, collapse = ",")))

df3 <- df2 |> 
  group_by(group) |> 
  summarize(split_weeks = unique(str_c(split_weeks, collapse = ","))) |> 
  separate_rows(split_weeks, sep = ",", convert = TRUE) |>
  distinct() |> 
  mutate(value = 1L) |>
  full_join(y = data.frame(split_weeks = 1:10)) |> 
  pivot_wider(names_from = split_weeks,
              names_prefix = "week_",
              values_from = value,
              values_fill = 0L,
              names_expand = TRUE) |> 
  filter(!is.na(group))

df4 <- df2 |> 
  ungroup() |> 
  select(-split_weeks, -n_rows) |> 
  pivot_wider(names_from = row_number, values_from = -group) |> 
  bind_cols(x = df3 |> select(-group), y = _)

- deschen

Answer 3

library(tidyverse)

periods <- tibble(
  group  = c(1, 1, 1, 2, 2, 2),
  start  = c(2, 2, 2, 7, 7, 7), 
  stop   = c(4, 7, 8, 7, 8, 9), 
  unstop = c(5, 7, 10, 7, 9, 10)
)

LAST <- 10

我认为将小组内部的启动/停止/取消停止逻辑重新编码为每行单独的启动/停止是有意义的。我们可以称它们为rstart/rstop。根据您的规则，它们可以按以下方式创建：

(periods <- periods %>% 
  group_by(group) %>% 
  transmute(
    period = row_number(),
    rstart = if_else(period == 1L, start, unstop),
    rstop  = if_else(period == 1L, stop,  lead(stop, default = LAST))
  ) %>% 
  ungroup()
)
#> # A tibble: 6 x 4
#>   group period rstart rstop
#>   <dbl>  <int>  <dbl> <dbl>
#> 1     1      1      2     4
#> 2     1      2      7     8
#> 3     1      3     10    10
#> 4     2      1      7     7
#> 5     2      2      9     9
#> 6     2      3     10    10

现在，我们可以通过 group_by -> summarise 生成活动伸展。在这里，我们还添加了一个指示列“active”，以显示给定的周数是活动的。

(periods <- periods %>% 
  group_by(group, period) %>% 
  summarise(
    weeks = rstart:rstop, 
    active = 1L, 
    .groups = "drop"
  ) 
)
#> # A tibble: 9 x 4
#>   group period weeks active
#>   <dbl>  <int> <int>  <int>
#> 1     1      1     2      1
#> 2     1      1     3      1
#> 3     1      1     4      1
#> 4     1      2     7      1
#> 5     1      2     8      1
#> 6     1      3    10      1
#> 7     2      1     7      1
#> 8     2      2     9      1
#> 9     2      3    10      1

在使用pivot_wider之后，如果要使未观察到的周出现在输出中，我们可以将周列转换为因子，并使用fct_expand添加缺失级别。我还添加了fct_inseq以确保输出中的列按预期排序。完成后，我们可以使用pivot_wider获取宽格式。请注意，names_expand = TRUE参数会给我们提供我们添加到周列中的级别。

periods %>% 
  mutate(
    weeks = as_factor(weeks) %>% 
      fct_expand(as.character(1:LAST)) %>% 
      fct_inseq()
  ) %>% 
  pivot_wider(
    names_from = weeks, 
    names_expand = TRUE,
    values_from = active,
    values_fill = 0L, 
    names_prefix = "week"
  )
#> # A tibble: 6 x 12
#>   group period week1 week2 week3 week4 week5 week6 week7 week8 week9 week10
#>   <dbl>  <int> <int> <int> <int> <int> <int> <int> <int> <int> <int>  <int>
#> 1     1      1     0     1     1     1     0     0     0     0     0      0
#> 2     1      2     0     0     0     0     0     0     1     1     0      0
#> 3     1      3     0     0     0     0     0     0     0     0     0      1
#> 4     2      1     0     0     0     0     0     0     1     0     0      0
#> 5     2      2     0     0     0     0     0     0     0     0     1      0
#> 6     2      3     0     0     0     0     0     0     0     0     0      1

创建于2022-05-09，使用reprex 包(v2.0.1)。

- Peter H.