r - 使用 purrr 函数的全局赋值

Question

如何用 purrr 函数替换 for 循环？有很多案例是straightforward ，但在这种情况下，我试图在循环期间进行赋值。词法作用域用于查找要修改的对象，但不保存进度。就好像修改只发生在每次迭代中，然后就被丢弃了。

结果应该更新矩阵 dead_yes 和 dead_no。

根据@hadley 的评论编辑为使用 pwalk() 来强调副作用而不是输出。我们不希望退回任何东西；相反，我们只是修改现有变量。

library(tidyverse)
library(faraway)
data(femsmoke)

dead_yes <- matrix(NA, nrow = length(unique(femsmoke$smoker)), ncol = length(unique(femsmoke$age)))
dead_no <- matrix(NA, nrow = length(unique(femsmoke$smoker)), ncol = length(unique(femsmoke$age)))

colnames(dead_yes) <- colnames(dead_no) <- unique(femsmoke$age)
rownames(dead_yes) <- rownames(dead_no) <- unique(femsmoke$smoker)

w <- unique(femsmoke$age)
v <- unique(femsmoke$smoker)
u <- unique(femsmoke$dead)

pwalk(list(
  row = match(femsmoke$smoker, v),
  col = match(femsmoke$age, w),
  y = femsmoke$y,
  dead = femsmoke$dead
), function(row, col, y, dead) {
  if (dead == "yes") {
    dead_yes[row, col] <- y
  } else {
    dead_no[row, col] <- y
  }
})

由 reprexpackage 创建于 2018-09-29 (v0.2.0).

Answer 1

如果你真的想改变 x全局环境中的对象，你需要使用 <<-用于迭代机内部的分配(对于 [lv]apply()或 purrr::map() ).通用示例:

(x <- rep(NA_integer_, 3))
#> [1] NA NA NA

purrr::map_dbl(1:3, function(i) x[[i]] <- -i)
#> [1] -1 -2 -3
x
#> [1] NA NA NA

vapply(1:3, function(i) x[[i]] <- -i, integer(1))
#> [1] -1 -2 -3
x
#> [1] NA NA NA

purrr::map_dbl(1:3, function(i) x[[i]] <<- -i)
#> [1] -1 -2 -3
x
#> [1] -1 -2 -3

vapply(1:3, function(i) x[[i]] <<- -2L * i, integer(1))
#> [1] -2 -4 -6
x
#> [1] -2 -4 -6

在父环境中修改对象确实违背了但是，这些功能的功能性质。通常，当您必须使用 <<- 时，这通常意味着有另一种方法来解决这个问题。在这种情况下，数据 reshape 似乎是考虑原始任务的另一种方式。

但是，要回答原始问题，请使用 <<-制作原创代码“工作”。我切换到purrr::pwalk()强调副作用并转换dead从因素到性格。

library(tidyverse)
library(faraway)
data(femsmoke)

dead_yes <- matrix(NA, nrow = length(unique(femsmoke$smoker)), ncol = length(unique(femsmoke$age)))
dead_no <- matrix(NA, nrow = length(unique(femsmoke$smoker)), ncol = length(unique(femsmoke$age)))

colnames(dead_yes) <- colnames(dead_no) <- unique(femsmoke$age)
rownames(dead_yes) <- rownames(dead_no) <- unique(femsmoke$smoker)

w <- unique(femsmoke$age)
v <- unique(femsmoke$smoker)
u <- unique(femsmoke$dead)

pwalk(list(
  row = match(femsmoke$smoker, v),
  col = match(femsmoke$age, w),
  y = femsmoke$y,
  dead = as.character(femsmoke$dead)
), function(row, col, y, dead) {
  if (dead == "yes") {
    dead_yes[row, col] <<- y
  } else {
    dead_no[row, col] <<- y
  }
})
dead_yes
#>     18-24 25-34 35-44 45-54 55-64 65-74 75+
#> yes     2     3    14    27    51    29  13
#> no      1     5     7    12    40   101  64
dead_no
#>     18-24 25-34 35-44 45-54 55-64 65-74 75+
#> yes    53   121    95   103    64     7   0
#> no     61   152   114    66    81    28   0

^{由 reprex package 创建于 2018-09-29 (v0.2.1)}