北京大学R语言教程(李东风)第25章： 函数式编程和数据框列表列

f <- function(){
  opar <- par(mfrow=c(1,2))
  on.exit(par(opar), add=TRUE)
  plot((-10):10)
  plot((-10):10, ((-10):10)^2)
}
f()

y <- vector(mode = "list", length = length(x))
for(i in seq_along(x)){
  y[[i]] <- f(x[[i]])
}
names(y) <- names(x)

map数据框处理示例

下面举例说明map函数对数据框处理的应用。

typeof()函数求变量的存储类型，如

typeof(d.class[["height"]])

## [1] "double"

这里d.class是数据框，
数据框也是列表，
每个列表元素是数据框的一列。

如下程序使用purrr::map()求每一列的存储类型，
map的结果总是列表，每个列表元素对应于输入的一个元素，
如:

library(purrr)
map(d.class, typeof)

## $name
## [1] "character"
## 
## $sex
## [1] "integer"
## 
## $age
## [1] "double"
## 
## $height
## [1] "double"
## 
## $weight
## [1] "double"

当结果比较简单时，
保存为列表不够方便，
函数unlist()可以将比较简单的列表转换为基本类型的向量，如：

map(d.class, typeof) |> unlist()

##        name         sex         age      height      weight 
## "character"   "integer"    "double"    "double"    "double"

实际上，关于一个数据框的结构，
用str()函数或者dplyr::glimpse()函数可以得到更为详细的信息：

## spc_tbl_ [19 × 5] (S3: spec_tbl_df/tbl_df/tbl/data.frame)
##  $ name  : chr [1:19] "Alice" "Becka" "Gail" "Karen" ...
##  $ sex   : Factor w/ 2 levels "M","F": 2 2 2 2 2 2 2 2 2 1 ...
##  $ age   : num [1:19] 13 13 14 12 12 15 11 15 14 14 ...
##  $ height: num [1:19] 56.5 65.3 64.3 56.3 59.8 66.5 51.3 62.5 62.8 69 ...
##  $ weight: num [1:19] 84 98 90 77 84.5 ...
##  - attr(*, "spec")=
##   .. cols(
##   ..   .default = col_double(),
##   ..   name = col_character(),
##   ..   sex = col_factor(levels = c("M", "F"), ordered = FALSE, include_na = FALSE),
##   ..   age = col_double(),
##   ..   height = col_double(),
##   ..   weight = col_double()
##   .. )
##  - attr(*, "problems")=<externalptr>

## Rows: 19
## Columns: 5
## $ name   <chr> "Alice", "Becka", "Gail", "Karen", "Kathy", "Mary", "Sandy", "S…
## $ sex    <fct> F, F, F, F, F, F, F, F, F, M, M, M, M, M, M, M, M, M, M
## $ age    <dbl> 13, 13, 14, 12, 12, 15, 11, 15, 14, 14, 14, 15, 12, 13, 12, 16,…
## $ height <dbl> 56.5, 65.3, 64.3, 56.3, 59.8, 66.5, 51.3, 62.5, 62.8, 69.0, 63.…
## $ weight <dbl> 84.0, 98.0, 90.0, 77.0, 84.5, 112.0, 50.5, 112.5, 102.5, 112.5,…

map返回基本类型向量

purrr::map()总是返回列表。
如果确知其调用的函数总是返回某种类型的标量值，
可以用map的变种：

• map_lgl()：返回逻辑向量；
• map_int()：返回整型向量；
• map_dbl(): 返回双精度浮点型向量(double类型)；
• map_chr(): 返回字符型向量。

比如，
求mtcars各列类型，
因为确知typeof()函数对每列返回一个标量字符串，所以可以写成：

##        name         sex         age      height      weight 
## "character"   "integer"    "double"    "double"    "double"

用map_lgl()返回每一列是否数值型列：

map_lgl(d.class, is.numeric)

##   name    sex    age height weight 
##  FALSE  FALSE   TRUE   TRUE   TRUE

...形参

在R函数的形参中，
允许有一个特殊的...形参（三个小数点），
这在调用泛函类型的函数时起到重要作用。
在调用泛函时，
所有没有形参与之匹配的实参，
不论是带有名字还是不带有名字的，
都自动归入这个参数，
将会由泛函传递给作为其自变量的函数。
...参数的类型相当于一个列表，
列表元素可以部分有名部分无名，
用list(...)可以将其转换成列表再访问。

例如，函数mean()可以计算去掉部分最低、最高值之后的平均值，
用选项trim=指定一个两边分别舍弃的值的个数比例。
为了将d.cancer的v0, v1列计算上下各自扣除10%的平均值，
需要利用map_dbl()函数的...参数输入trim选项值，如：

map_dbl(d.cancer[,c("v0", "v1")], 
  mean, trim=0.10)

##        v0        v1 
## 103.74357  40.98786

用tidyverse方式：

d.cancer |>
  summarise(across(c(v0, v1),
    ~ mean(., trim = 0.10)))

## # A tibble: 1 × 2
##      v0    v1
##   <dbl> <dbl>
## 1  104.  41.0

选择数值型列，然后用map_double计算截尾的均值：

d.cancer[, map_lgl(d.cancer, is.numeric)] |>
  map_dbl(mean, trim=0.10, na.rm = TRUE)

##        id       age        v0        v1 
##  17.50000  64.31579 103.74357  40.98786

purrr包提供了一个keep函数，
可以专门用来选择数据框各列或列表元素中满足某种条件的子集，
这个条件用一个返回逻辑值的函数来给出。如：

d.cancer |>
  keep(is.numeric) |>
  map_dbl(mean, trim = 0.10, na.rm = TRUE)

##        id       age        v0        v1 
##  17.50000  64.31579 103.74357  40.98786

也可以用tidyverse解决：

d.cancer |>
  summarise(across(
    where(is.numeric),
    ~ mean(., trim = 0.10, na.rm = TRUE) ))

## # A tibble: 1 × 4
##      id   age    v0    v1
##   <dbl> <dbl> <dbl> <dbl>
## 1  17.5  64.3  104.  41.0

需要注意的是，
在map类泛函中...仅用来将额外的选项传递给要调用的函数，
不支持向量化，
如果需要对两个或多个自变量的对应元素作变换，
需用用purrr包的map2等函数。
如果泛函中调用的是无名函数，
则...参数会造成变量作用域理解困难。

用map处理strsplit函数结果示例

假设有4个学生的3次小测验成绩，
每个学生的成绩记录到了一个以逗号分隔的字符串中，如：

s <- c('10, 8, 7', 
      '5, 2, 2', 
      '3, 7, 8', 
      '8, 8, 9')

对单个学生，可以用strsplit()函数把三个成绩拆分，如：

strsplit(s[1], ',', fixed=TRUE)[[1]]

## [1] "10" " 8" " 7"

注意这里strsplit()的结果是仅有一个元素的列表，
用了“[[...]]”格式取出列表元素。
拆分的结果可以用as.numeric()转换为有三个元素的数值型向量：

strsplit(s[1], ',', fixed=TRUE)[[1]] |> as.numeric()

## [1] 10  8  7

还可以求三次小测验的总分：

strsplit(s[1], ',', fixed=TRUE)[[1]] |> 
  as.numeric() |>
  sum()

## [1] 25

用strsplit()处理有4个字符串的字符型向量s,
结果是长度为4的列表：

tmpr <- strsplit(s, ',', fixed=TRUE); tmpr

## [[1]]
## [1] "10" " 8" " 7"
## 
## [[2]]
## [1] "5"  " 2" " 2"
## 
## [[3]]
## [1] "3"  " 7" " 8"
## 
## [[4]]
## [1] "8"  " 8" " 9"

用map()和as.numeric()可以把列表中所有字符型转为数值型，
输出为一个列表，
然后再对各个列表元素中的向量求和。
使用管道运算符表达逐步的操作：

s |>
  strsplit(split=",", fixed=TRUE) |>
  map(as.numeric) |>
  map_dbl(sum)

## [1] 25  9 18 25

在map中使用无名函数以及简写方法

map()中调用的函数可以是在map()中直接现场定义的无名函数。

仍考虑上面的问题，有4个学生，
每个学生有三门成绩，成绩之间用逗号分隔。
将每个学生的成绩拆分为三个字符串后，
就可以对每个学生调用一个统一的无名函数，
将字符型转换为数值型以后求和：

s |> 
  strsplit(split=",", fixed=TRUE) |>
  map_dbl(\(x) sum(as.numeric(x)))

## [1] 25  9 18 25

使用无名函数格式比较复杂，
purrr包为在map()等泛函中使用无名函数提供了简化的写法，
将无名函数写成“~ 表达式”格式，
表达式就是无名函数定义，
用.x表示只有一个自变量时的自变量名，
用.x和.y表示只有两个自变量时的自变量名，
用..1、..2、..3这样的名字表示有多个自变量时的自变量名。
如：

s |> 
  strsplit(split=",", fixed=TRUE) |>
  map_dbl(~ sum(as.numeric(.x)))

## [1] 25  9 18 25

需要注意的是，
如果map()等泛函中的无名函数需要访问其它变量的话，
需要理解其变量作用域或访问环境。
另外，
无名函数中的其它变量在每次被map()应用到输入列表的元素时都会重新计算求值。
建议这样的情况改用有名函数，
这样其中访问其它变量时作用域规则比较容易掌控，
也不会重复求值。

在map中提取列表元素成员的简写

较为复杂的数据，
有时表现为列表的列表，
每个列表元素都是列表或者向量。
JSON、YAML等格式转换为R对象就经常具有这种嵌套结构。

例如，
有如下的嵌套格式数据，
这样的数据不利于用数据框格式保存：

od <- list(
  list(
    101, name="李明", age=15, 
    hobbies=c("绘画", "音乐")),
  list(
    102, name="张聪", age=17,
    hobbies=c("足球"),
    birth="2002-10-01")
)

为了取出每个列表元素的第一项，本来应该写成：

## [1] 101 102

或：

## [1] 101 102

purrr包提供了进一步的简化写法，
在需要一个函数或者一个“~ 表达式”的地方，
可以用整数下标值表示对每个列表元素提取其中的指定成分，如：

## [1] 101 102

类似地，可以在需要函数的地方写一个成员名，
提取每个列表元素中该成员，如：

## [1] "李明" "张聪"

在应该用函数的地方还可以提供一个列表，
列表元素为成员序号或者成员名，
进行逐层挖掘，如：

map_chr(od, list("hobbies", 1))

## [1] "绘画" "足球"

表示取出每个列表元素的hobbies成员的第一个元素（每人的第一个业余爱好）。

取出不存在的成员会出错，
但可以用一个.default选项指定查找不到成员时的选项，
如：

map_chr(od, "birth", .default=NA)

## [1] NA           "2002-10-01"

数据框分组处理示例

对d.class数据框，
希望分成男女生两个组，
每组内建立用身高预测体重的一元线性回归模型，
提取各模型的斜率项。
基本R的split函数可以按数据框的某列将数据框分成若干个子数据框，
结果为子数据框的列表。
借助于purrr包的map类函数和管道运算符，
可以将分组建模过程写成：

d.class |>
  split(d.class[["sex"]]) |>
  map(~ lm(weight ~ height, data=.x)) |>
  # 这里的“.”是map需要输入的无名函数的自变量
  map(coef) |>
  map_dbl(2)

##        M        F 
## 3.912549 3.424405

这些步骤用基本R的lapply或者for循环也能够完成，
但会更难读懂，
或者需要生成许多中间临时变量，
不如上面例子这样步骤清晰而且不需要产生中间结果。
上述问题使用tidyr的nest和unnest可以将分组结果、回归结果保存为tibble的列表列，
管理起来更为直观，
见25.4。

dplyr包和plyr包与这个例子的思想类似，
只不过更有针对性。

输入输出类型相同的modify函数

purrr的modify函数与map函数作用类似，
并不会原地修改输入数据，
而是制作修改后的副本，
输出的结果类型与输入数据的结果类型相同，
所以可以用来修改数据框各列生成一个副本数据框。

比如，
对d.class中的三个数值型列，
都减去列中位数，其它列保持不变：

d1 <- modify(d.class, ~ if(is.numeric(.x)) .x - median(.x) else .x )

purrr包还提供了一个modify_if()函数，
可以对满足条件的列进行修改，如：

d2 <- modify_if(d.class, is.numeric, ~ .x - median(.x))

对两个自变量的相同下标元素调用函数

map()函数仅支持一个输入数据的列表或向量。
map2()函数支持两个输入数据的列表或向量，
map2(x, y, f, ...)对每个下标i调用f(x[[i]], y[[i]], ...)，
结果返回一个列表。
如果知道函数f()会返回类型确定的标量值，
可以用map2_dbl()等变种。

例如，
d1是某市2001年四个季度的若干项经济指标，
d2是2002年的对应指标，
计算每项指标年度总和的同比增幅：

d1 <- tibble(
  x1 = c(106, 108, 103, 110),
  x2 = c(101, 112, 107, 105) )
d2 <- tibble(
  x1 = c(104, 111, 112, 109),
  x2 = c(102, 114, 105, 107) )
d3 <- map2_dbl(d1, d2, ~ (sum(.y) - sum(.x)) / sum(.x))
knitr::kable(list(d1=d1, d2=d2, d3=as_tibble(rbind(d3))))

上述map2_dbl()调用等价于：

d3 <- numeric(2)
names(d3) <- names(d1)
for(j in seq_along(d1)){
  d3[[j]] <- (sum(d2[[j]]) - sum(d1[[j]]))/sum(d1[[j]])
}
d3

##          x1          x2 
## 0.021077283 0.007058824

如果计算结果与两个输入数据类型相同，
可以用modify2()。
比如，
上面的例子数据计算每个指标的同比增幅：

modify2(d1, d2, ~ (.y - .x) / .x)

## # A tibble: 4 × 2
##         x1       x2
##      <dbl>    <dbl>
## 1 -0.0189   0.00990
## 2  0.0278   0.0179 
## 3  0.0874  -0.0187 
## 4 -0.00909  0.0190

注意和modify()一样，
上述程序并不会修改d1和d2的值，
而是返回与其类型和大小相同的一个数据框。

map2()允许输入的x和y两个列表其中一个长度为1，
这时长度为1的列表的元素被重复利用。如：

d1b <- d1[,1,drop=FALSE]
map2_dbl(d1b, d2, ~ (sum(.y) - sum(.x)) / sum(.x))

##         x1         x1 
## 0.02107728 0.00234192

基本R的Map()函数起到与map2()和pmap()类似的作用。

不产生输出的walk类函数

有时仅需要遍历一个数据结构调用函数进行一些显示、绘图，
这称为函数的副作用，
不需要返回结果。
purrr的walk函数针对这种情形。

例如，
显示数据框中每个变量的类别：

walk(d.class, ~ cat(typeof(.x), "\n"))

## character 
## integer 
## double 
## double 
## double

上面这个例子缺点是没有显示对应的变量名。

walk2()函数可以接受两个数据自变量，
类似于map2()。
例如，
需要对一组数据分别保存到文件中，
就可以将数据列表与保存文件名的字符型向量作为walk2()的两个数据自变量。
下面的程序将d.class分成男女生两个子集，
保存到两个csv文件中：

dl <- split(d.class, d.class[["sex"]])
walk2(dl, paste0("class-", names(dl), ".csv"), 
      ~ write.csv(.x, file=.y))

改用管道运算符：

d.class |>
  split(d.class[["sex"]]) |>
  walk2(paste0("class-", names(.), ".csv"), 
        ~ write.csv(.x, file=.y))

事实上，
walk、walk2并不是没有输出，
它们返回不显示的第一个自变量，
所以也适合用在管道运算的中间使得管道不至于中断。

基本R没有提供类似walk的功能。

可同时访问下标或元素名与元素值的imap类函数

在前面用walk函数显示数据框各列类型的例子中，
没有能够同时显示变量名。
如果x有元素名，
imap(x, f)相当于map2(x, names(x), f)；
如果x没有元素名，
imap(x, f)相当于map2(x, seq_along(x), f)。
iwalk()与imap()类似但不返回信息。
f是对数据每一项要调用的函数，
输入的函数的第二个自变量或者无名函数的.y自变量会获得输入数据的元素名或者元素下标。
imap_chr()等是固定返回类型的变种。

例如，
显示数据框各列的变量名：

iwalk(d.class, ~ cat(.y, ": ", typeof(.x), "\n"))

## name :  character 
## sex :  integer 
## age :  double 
## height :  double 
## weight :  double

返回字符型向量的写法：

imap_chr(d.class, ~ paste0(.y, " ==> ", typeof(.x))) |>
  unname()

## [1] "name ==> character" "sex ==> integer"    "age ==> double"    
## [4] "height ==> double"  "weight ==> double"

输入数据没有元素名的演示：

dl <- list(1:5, 101:103)
iwalk(dl, ~ cat("NO. ", .y, ": ", .x[[1]], "\n"))

## NO.  1 :  1 
## NO.  2 :  101

显示了每个列表元素的第一项。

基本R没有提供类似imap的功能。

多个数据自变量的pmap类函数

R的函数调用时支持向量化，
可以很好地处理各个自变量是向量的情形，
但是当自变量是列表、数据框等复杂类型时不能自动进行向量化处理。
purrr包的pmap类函数支持对多个列表、数据框、向量等进行向量化处理。
pmap不是将多个列表等作为多个自变量，
而是将它们打包为一个列表。
所以，
map2(x, y, f)用pmap()表示为pmap(list(x, y), f)。

在确知输出类型时可以用pmap_chr(), pmap_dbl()等变种，
在不需要输出结果时可以用pwalk()。

比如，
将三个列表中的对应项用c()函数连接：

x <- list(101, name="李明")
y <- list(102, name="张聪")
z <- list(103, name="王国")
pmap(list(x, y, z), c)

## [[1]]
## [1] 101 102 103
## 
## $name
## [1] "李明" "张聪" "王国"

因为数据框是列表，
所以pmap()也可以输入一个数据框和要并行执行的函数，
对数据框的每一行执行该函数。
例如：

d <- tibble::tibble(
  x = 101:103, 
  y=c("李明", "张聪", "王国"))
knitr::kable(d)

pmap_chr(d, \(...) paste(..., sep=":"))

## [1] "101:李明" "102:张聪" "103:王国"

pmap()和其它的map()类函数有一个区别是，
因为将输入数据打包在一个列表中，
而列表元素是有变量名的，
这样就可以将列表变量名取为要调用的函数的自变量名，
使得对输入列表中各元素的每个成员调用函数时，
可以带有对应的形参名调用。

例如，mean()函数可以计算去掉最小、最大一部分后的平均值，
mean(x, trim)用trim选项控制两端分别去掉的比例，
但是trim选项必须是标量。
用map_dbl()解决方法如下：

set.seed(101)
x <- rcauchy(1000)
trims <- c(0.05, 0.1, 0.2, 0.3, 0.4)
map_dbl(trims, ~ mean(x=x, trims=.x))

## [1] 0.7271278 0.7271278 0.7271278 0.7271278 0.7271278

可以用pmap()的列表元素名自动对应到调用函数形参名的方法：

pmap_dbl(list(trims = trims), mean, x=x)

## [1] 0.7271278 0.7271278 0.7271278 0.7271278 0.7271278

或：

pmap_dbl(list(trims = trims), ~ mean(x))

## [1] 0.7271278 0.7271278 0.7271278 0.7271278 0.7271278

基本R的Map()函数提供了类似的功能，
但是不允许多个自变量中有长度为1的；
基本R的mapply()函数与Map()类似，
但是会像sapply()函数那样试图自动找到最简化的输出数据结构，
这在通用程序中会使得结果不可控。

reduce函数

许多二元运算符如加法、乘法，
可以很自然地推广到多个运算元之间的运算，
变成连加、连乘积等等。
某些常用的操作已经变成了R函数，
比如sum()、prod()，
但是其它一些运算，
包括用函数表示的运算，
也需要推广到对多个进行，
比如intersect(x, y)求两个集合的交集，
希望能推广到求多个集合的交集。

purrr包的reduce函数把输入列表（或向量）的元素逐次地用给定的函数进行合并计算。
比如，设f(x,y)是一个二元函数，
设z是有4个元素的列表，
则reduce(z, f)表示

f(f(f(z[[1]], z[[2]]), z[[3]]), z[[4]])

例如，

## [1] 10

实际执行的是(((1+2)+3)+4)。
当然，求1:4的和只需要sum(1:4)，
但是reduce可以对元素为复杂类型的列表进行逐项合并计算。

考虑多个集合的交集的问题。
下面的例子产生了4个集合，
然后反复调用intersect()求出了交集：

x <- list(
  c(2, 3, 1, 3, 1), 
  c(1, 5, 3, 3, 2),
  c(5, 4, 2, 5, 3),
  c(1, 4, 3, 2, 5))
intersect(intersect(intersect(x[[1]], x[[2]]), x[[3]]), x[[4]])

## [1] 2 3

也可以用管道运算写成:

x[[1]] |> intersect(x[[2]]) |> intersect(x[[3]]) |> intersect(x[[4]])

## [1] 2 3

还可以写成循环:

y <- x[[1]]
for(i in 2:4) y <- intersect(y, x[[i]])
y

## [1] 2 3

都比较繁琐。

利用purrr包的reduce函数，只要写成

## [1] 2 3

泛函的好处是需要进行的变换或计算是作为参数输入的，
只要输入其它函数就可以改变要做的计算，
比如，
变成求各个集合的并集：

## [1] 2 3 1 5 4

reduce()支持...参数，
所以可以给要调用的函数额外的自变量或选项。

reduce函数对多个输入默认从左向右计算，
可以用.dir = "backward"选项改为从右向左合并。

可以用选项.init给出合并初值，
在通用程序中使用reduce()时应该提供此选项，
这样如果输入了零长度数据，
可以有一个默认的返回值；
输入非零长度数据时，
此初值作为第一个元素之前的值参与计算，
所以一定要取为与要进行的运算一致的值，
比如连加的初始值自然为0，
连乘积的初始值自然为1，
多个集合交集的初始值为全集（所有参与运算的各个集合应为此初值的子集），
等等。

基本R的Reduce()函数提供了类似purrr::reduce()的功能，
不支持...参数。

reduce2函数

reduce2(x, y, f)中的x是要进行连续运算的数据列表或向量，
而y是给这些运算提供不同的参数。
如果没有.init初始值，
f仅需调用length(x)-1次，
所以y仅需要有length(x)-1个元素；
如果有.init初始值，
f需要调用length(x)次，
y也需要与x等长。

accumulate函数

对于加法，
R的sum()函数可以计算连加，
而cumsum()函数可以计算逐步的连加。如：

## [1] 10

## [1]  1  3  6 10

purrr::reduce()将连加推广到了其它的二元运算，
purrr::accumulate()则类似cumsum()的推广。

例如，对前面例子中的4个集合，
计算逐步的并集，
结果的第一项保持原来的第一项不变：

## [[1]]
## [1] 2 3 1 3 1
## 
## [[2]]
## [1] 2 3 1 5
## 
## [[3]]
## [1] 2 3 1 5 4
## 
## [[4]]
## [1] 2 3 1 5 4

将上述结果简化显示：

accumulate(x, union) |>
  map(~ sort(unique(.x)))

## [[1]]
## [1] 1 2 3
## 
## [[2]]
## [1] 1 2 3 5
## 
## [[3]]
## [1] 1 2 3 4 5
## 
## [[4]]
## [1] 1 2 3 4 5

Map-reduce算法

Map-reduce是大数据技术中的重要算法，
在Hadoop分布式数据库中主要使用此算法思想。
将数据分散存储在不同计算节点中，
将需要的操作先映射到每台计算节点，
进行信息提取压缩，
最后用reduce的思想将不同节点的信息整合在一起。

every(d.class, is.numeric)

detect(c(1, 5, 77, 105, 99, 123), ~ .x >= 100)

detect_index(c(1, 5, 77, 105, 99, 123),
  ~ .x >= 100)

d.class |>
  keep(is.numeric) |>
  map_dbl(~ sum(.x ^ 2))

d.class |>
  summarise(across(
    where(is.numeric),
    \(x) sum(x^2)  ))

modify_if(d.class, is.numeric, `/`, 100) |> head()

vapply(X, FUN, FUN.VALUE, ...)

vapply(d.class, typeof, "")

d <- data.frame(
  x = c(1, 7, 2),
  y = c(3, 5, 9))
Map(function(x) sum(x^2), d)

lapply(d, function(x) sum(x^2))

unlist(Map(max, d$x, d$y))

set.seed(5)
x <- replicate(4, sample(
  1:5, size=5, replace=TRUE), simplify=FALSE); x

f <- function(x) x > 0 & x < 1
Filter(f, c(-0.5, 0.5, 0.8, 1))

x <- c(-0.5, 0.5, 0.8, 1)
x[x>0 & x < 1]

library(purrr)
summary.df.numeric <- function(df, FUN, ...){
  df |>
    keep(is.numeric) |>
    map_dbl(FUN, ...)
}

summary.df.numeric(d.cancer, min, na.rm=TRUE)

summary.df.numeric2 <- function(df, FUN, ...){
  res <- c()
  nd <- c()
  for(j in seq_along(df)){
    if(is.numeric(df[[j]])){
      resj <- FUN(df[[j]], ...) 
      res <- cbind(res, resj)
      nd <- c(nd, names(df)[j])
    }
  }
  if(ncol(res)>0) {
    colnames(res) <- nd
    if(nrow(res) == 1) {
      res <- c(res)
      names(res) <- nd
    }
  }
  res
}
summary.df.numeric2(d.cancer, min, na.rm=TRUE)

summary.df.numeric <- function(df, FUN, ...){
  Filter(is.numeric, df) |>
    sapply(FUN, ...)
}

f.gen <- function(){
  runTimes <- 0

  function(){
    runTimes <<- runTimes + 1
    print(runTimes)
  }
}
f <- f.gen()
f()

c1 <- f.gen()
c2 <- f.gen()
c1()

make_stop_watch <- function(){
  saved.time <- proc.time()[3]
  
  function(){
    t1 <- proc.time()[3]
    td <- t1 - saved.time
    saved.time <<- t1
    cat("流逝时间（秒）：", td, "\n")
    invisible(td)
  }
}
ticker <- make_stop_watch()
ticker()
## 流逝时间（秒）： 0 
for(i in 1:1000) sort(runif(10000))
ticker()
## 流逝时间（秒）： 1.53 

make.pf <- function(power){
  function(x) x^power
}
p <- 2
square <- make.pf(p)
p <- 3
square(2)

make.pf <- function(power){
  force(power)
  function(x) x^power
}
p <- 2
square <- make.pf(p)
p <- 3
square(2)

dot_every <- function(f, n) {
  force(f)
  force(n)
  
  i <- 0
  function(...) {
    i <<- i + 1
    if (i %% n == 0) cat(".")
    f(...)
  }
}
sim <- function(i){
  x <- runif(1E6)
  invisible(sort(x))
}
walk(1:100, dot_every(sim, 10))

walk(1:100, sim, .progress = TRUE)

d.cancer |>
  group_by(type) |>
  nest()

fmod <- function(subdf)  lm(v1 ~ v0, data = subdf)
mod.cancer <- d.cancer |>
  group_by(type) |>
  nest() |>
  mutate(lmr = map(data, fmod))
mod.cancer

frsqr <- function(mod){
  summary(mod)$r.squared
}
mod.cancer |>
  mutate(
    r.squared = map_dbl(lmr, frsqr)) |>
  select(-data, -lmr)

d.cancer |>
  group_by(type) |>
  nest() |>
  mutate(
    lmr = map(data, ~ lm(v1 ~ v0, data = .x)),
    r.squared = map_dbl(lmr, ~ summary(.x)$r.squared)) |>
  select(-data, -lmr)

fextract <- function(mod){
  x1 <- coef(mod)
  tibble(
    intercept = x1[1],
    v0 = x1[2],
    r.squared = summary(mod)$r.squared)
}
mod.cancer |>
  mutate(
    outlist = map(lmr, fextract))

mod.cancer |>
  mutate(
    outlist = map(lmr, fextract)) |>
  select(-data, -lmr) |>
  unnest(outlist)

fcoefmat <- function(mod){
  as_tibble(
    summary(mod)$coefficients,
    rownames="term")
}
mod.cancer |>
  mutate(
    outlist = map(lmr, fcoefmat)) |>
  select(-data, - lmr) |>
  unnest(outlist)

mod.cancer |>
  mutate(
    outlist = map(lmr, broom::tidy)) |>
  select(-data, -lmr) |>
  unnest(outlist)

mod.cancer |>
  mutate(
    v1hat = map(lmr, ~ fitted(.))) |>
  select(-lmr) |>
  unnest(c(data, v1hat))

vnames <- expand_grid(
  var = c("v0", "v1"),
  stat = c("min", "max")) |>
  pmap_chr(paste, sep="_")

d.cancer |>
  group_by(type) |>
  summarise(
    stat = list(vnames),
    value = list(c(range(v0), range(v1)))  ) |>
  unnest(c(stat, value))

d.cancer |>
  group_by(type) |>
  summarise(
    stat = list(vnames),
    value = list(c(range(v0), range(v1)))  ) |>
  unnest(c(stat, value)) |>
  separate(stat, into = c("variable", "stat"), sep="_") |>
  pivot_wider(
    names_from = "stat",
    values_from = "value"
  )

d1 <- tibble(
  id = 1:2,
  df = vector("list", length=2))
d1[["df"]][1] <- list(
  tibble(x=1, y=2)
)
d1[["df"]][2] <- list(
  tibble(x=11:12, y=21:22)
)
d1 |>
  unnest(cols = c(df))