Map 参差不齐到深度，但停在哨兵

Question

动机

我正在开发一个 R package 和一个基本的助手 function “ make() ”。 这个make() function 接受一个参差不齐的列表，然后将 function foo()映射到列表中的倒数第二个节点（“树枝”）上：那些孩子是叶子的节点。 到目前为止purrr::map_depth (..., .depth = -2, .ragged = TRUE)似乎很理想。

有一个问题：遍历必须在一个done_box节点处停止 - 或者我自己创建的一些哨兵 class -无论其深度如何，即使该节点也是（即继承自）任意深度的list 。 然后 function foo()将根据其 class 有条件地对节点进行 map。

挑战

不幸的是， purrr::vec_depth()的不灵活性在遇到目标节点时会引发错误：

Error in `.f()`:
! `x` must be a vector
Run `rlang::last_error()` to see where the error occurred.

---

创可贴解决方案

因此，我暂时在.map_depth()的源代码上编写了一个变体 .map_depth map_depth() ，其中.list_depth()替换vec_depth()来处理目标节点。 有关代码，请参阅代码部分。

然后，我可以创建一个哨兵quosure my_sentinel ，它为生成节点值的expression “装箱”（即包装在一个list ）。 由于此my_sentinel继承自list ，因此.list_depth()将为其quosure提供1的深度，并为哨兵本身提供2的深度。

在.depth为-2时， .map_depth() function 将因此以my_sentinel节点本身为目标。 按照设计， foo()会将其quosure标识为"my_sentinel" ，并将评估“取消装箱”该值的条件。

退税

不幸的是，自从首次捕获quosure quosure environment可能会发生变化。 因此，当最终调用.map_depth()时，它可能会“取消装箱”错误的值：错误更新的值。

因此，最终用户的行为可能会变得不稳定！

---

问题

是否有更清洁或规范的方法来purrr::map_*()将 function foo()到list的“树枝”（即.depth = -2的节点），同时停在像done_box这样的哨兵对象的节点?

建议

我很好奇purrr::map_if() ，有一些谓词 .p 可以测试.p和深度。 但是，我缺乏确认这是否可行的专业知识，更不用说canonical了。

---

代码

对于my_sentinel ：

my_sentinel <- function(x) {
  x_quo <- rlang::enquo0(x)
  
  # No pun intended.
  x_box <- list(x_quo)
  
  structure(x_box,
    class = c("my_sentinel", class(x_box))
  )
}

对于.map_depth() ：

# A variation on 'purrr::map_depth()' that accommodates objective leaves.
.map_depth <- function(.x, .depth, .f, ..., .ragged = FALSE) {
  if (!rlang::is_integerish(.depth, n = 1, finite = TRUE)) {
    abort("`.depth` must be a single number")
  }
  if (.depth < 0) {
    .depth <- .list_depth(.x) + .depth
  }
  .f <- purrr::as_mapper(.f, ...)
  .map_depth_rec(.x, .depth, .f, ..., .ragged = .ragged, .atomic = FALSE)
}


# A variation on 'purrr:::map_depth_rec()' that accommodates objective leaves.
.map_depth_rec <- function(.x, .depth, .f, ..., .ragged, .atomic) {
  if (.depth < 0) {
    rlang::abort("Invalid depth")
  }
  # TODO: Must this be addressed too (unlikely)?
  if (.atomic) {
    if (!.ragged) {
      rlang::abort("List not deep enough")
    }
    return(purrr::map(.x, .f, ...))
  }
  if (.depth == 0) {
    return(.f(.x, ...))
  }
  if (.depth == 1) {
    return(purrr::map(.x, .f, ...))
  }
  .atomic <- rlang::is_atomic(.x)
  purrr::map(.x, function(x) {
    .map_depth_rec(x, .depth - 1, .f, ..., .ragged = .ragged, 
                    .atomic = .atomic)
  })
}


# A variation on 'purrr::vec_depth()' that accommodates objective leaves.
.list_depth <- function(x) {
  if (rlang::is_null(x)) {
    0L
  }
  # TODO: Address this so a vector is treated as a leaf (or must users esc() for that?).
  else if (rlang::is_atomic(x)) {
    1L
  }
  else if (rlang::is_list(x)) {
    depths <- purrr::map_int(x, .list_depth)
    1L + max(depths, 0L)
  }
  # Accommodate objective leaves.
  else if (is.object(x)) {
    # TODO: Check if this should be 1L or (as I suspect) 0L!
    1L
  }
  else {
    rlang::abort("`x` must be a vector or an object")
  }
}

Answer 1

只需在 package rrapply （基本rapply的扩展版本rrapply()中提到 rrapply()，它可能已经提供了您正在寻找的功能。

使用以下虚拟列表，因为问题中没有提供数据：

## dummy data
l <- list(
  list("initial_node"),
  list(list("initial_node")),
  structure(list("initial_node"), class = c("list", "my_sentinal")),
  structure(list(list("initial_node")), class = c("list", "my_sentinal"))
)

在第一次调用中， my_sentinal class 递归地传播到每个子列表。 在第二次调用中，一些 function f应用于所有没有继承自my_sentinal class 的子列表的列表。 注意：这可能可以通过一些努力组合成一个调用，但分成两个单独的调用，代码可能更容易理解和理解。

## propagate my_sentinal class to deeper sublists
l1 <- rrapply(
  l, 
  classes ="list",
  condition = \(x) inherits(x, "my_sentinal"),
  f = \(x) {
    if(is.list(x[[1]])) x[] <- lapply(x, structure, class = c("list", "my_sentinal"))
    return(x)
  },
  how = "recurse"
)

## apply function to non-sentinal pen-ultimate nodes 
l2 <- rrapply(
  l1, 
  classes = "list",
  condition = \(x) !inherits(x, "my_sentinal") && !is.list(x[[1]]),
  f = \(x) lapply(x, \(xi) "processed_node")
)

str(l2)
#> List of 4
#>  $ :List of 1
#>   ..$ : chr "processed_node"
#>  $ :List of 1
#>   ..$ :List of 1
#>   .. ..$ : chr "processed_node"
#>  $ :List of 1
#>   ..$ : chr "initial_node"
#>   ..- attr(*, "class")= chr [1:2] "list" "my_sentinal"
#>  $ :List of 1
#>   ..$ :List of 1
#>   .. ..$ : chr "initial_node"
#>   .. ..- attr(*, "class")= chr [1:2] "list" "my_sentinal"
#>   ..- attr(*, "class")= chr [1:2] "list" "my_sentinal"

免责声明：我也是rrapply的维护者。