7. 函数式编程
2020-04-20 本文已影响0人
kkkkkkang
习题是我自己写的，没有参考答案，不对请指出
- 废话不多说，下面这个例子综合了列表中存储函数（后面还有更详细的例子）、隐函数和lapply()的用法
- 目的：对mtcars的每一列计算mean、median、sd、mad和IQR
#首先上面五个需求函数存储在列表中，然后lapply把它们交给隐函数（没有名字的函数），分别变成mean(x,na.rm = TRUE)、median(x,na.rm = TRUE)......
summary <- function(x) {
funs <- c(mean, median, sd, mad, IQR)
lapply(funs, function(f) f(x, na.rm = TRUE))
}
a <- lapply(mtcars,summary)
str(a)
List of 11
$ mpg :List of 5
..$ : num 20.1
..$ : num 19.2
..$ : num 6.03
..$ : num 5.41
..$ : num 7.38
$ cyl :List of 5
..$ : num 6.19
..$ : num 6
..$ : num 1.79
..$ : num 2.97
..$ : num 4
$ disp:List of 5
..$ : num 231
..$ : num 196
..$ : num 124
..$ : num 140
..$ : num 205
$ hp :List of 5
..$ : num 147
..$ : num 123
..$ : num 68.6
..$ : num 77.1
..$ : num 83.5
$ drat:List of 5
..$ : num 3.6
..$ : num 3.7
..$ : num 0.535
..$ : num 0.704
..$ : num 0.84
$ wt :List of 5
..$ : num 3.22
..$ : num 3.33
..$ : num 0.978
..$ : num 0.767
..$ : num 1.03
$ qsec:List of 5
..$ : num 17.8
..$ : num 17.7
..$ : num 1.79
..$ : num 1.42
..$ : num 2.01
$ vs :List of 5
..$ : num 0.438
..$ : num 0
..$ : num 0.504
..$ : num 0
..$ : num 1
$ am :List of 5
..$ : num 0.406
..$ : num 0
..$ : num 0.499
..$ : num 0
..$ : num 1
$ gear:List of 5
..$ : num 3.69
..$ : num 4
..$ : num 0.738
..$ : num 1.48
..$ : num 1
$ carb:List of 5
..$ : num 2.81
..$ : num 2
..$ : num 1.62
..$ : num 1.48
..$ : num 2
- 来，再来一题：利用lapply()和隐函数计算mtcars数据集中所有列的变异系数（标准差/平均值）
> lapply(mtcars,function(x) sd(x)/mean(x))
$mpg
[1] 0.2999881
$cyl
[1] 0.2886338
$disp
[1] 0.5371779
$hp
[1] 0.4674077
$drat
[1] 0.1486638
$wt
[1] 0.3041285
$qsec
[1] 0.1001159
$vs
[1] 1.152037
$am
[1] 1.228285
$gear
[1] 0.2000825
$carb
[1] 0.5742933
- 求解y = x^2 -x 在[0,10]的积分
> y <- function(x) x ^ 2 - x
> integrate(y,0,10)
283.3333 with absolute error < 3.1e-12
闭包：它可以将父函数的环境封装，并可以访问它的所有变量。
对象是带有函数的数据，闭包是带有数据的函数 ——John D.cook
#闭包就是函数编写的函数，常用到隐函数来实现
#下面利用父层次控制运算，子层次进行工作的思想创建一组幂函数
power <- function(exponent) {
function(x) {
x ^ exponent
}
}
square <- power(2)
square(2)
#> [1] 4
square(4)
#> [1] 16
cube <- power(3)
cube(2)
#> [1] 8
cube(4)
#> [1] 64
#查看闭包的不同环境
library(pryr)
unenclose(square)
#> function (x)
#> {
#> x^2
#> }
unenclose(cube)
#> function (x)
#> {
#> x^3
#> }
#通常情况下自己写的函数的环境就是全局环境，别人写的函数就是添加包环境，元函数(primitive function)，直接调用C代码，且没有相关联的环境
- 可变状态
#一般来说，函数的执行环境是临时的，但是闭包可以一直访问它创建的环境
#下面的例子中，counter_one和counter_two在执行是都可以获取它们自己的封闭环境，所以各自计数互不影响
> new_counter <- function() {
+ i <- 0
+ function() {
+ i <<- i + 1
+ i
+ }
+ }
> counter_one <- new_counter()
> counter_two <- new_counter()
>
> counter_one()
[1] 1
> counter_one()
[1] 2
> counter_two()
[1] 1
> counter_two()
[1] 2
> counter_two()
[1] 3
#不用全局赋值，就是下面这样
> i <- 0
> new_counter2 <- function() {
+ i <<- i + 1
+ i
+ }
> new_counter2()
[1] 1
> new_counter3 <- function() {
+ i <- 0
+ function() {
+ i <- i + 1
+ i
+ }
+ }
> new_counter3()
function() {
i <- i + 1
i
}
<environment: 0x0000018dd806dd20>
#这个new_counter3()没有输出，是因为虽然它可以向上查找其父环境中的i，但是执行完函数又被清除了（个人理解）
- 习题：创建一个pick函数，它根据给出的索引i值，返回带有参数x的函数，这个函数可以根据i值对x进行自己选取
> pick <- function(i){
+ function(x) x[[i]]
+ }
> pick(5)
function(x) x[[i]]
<environment: 0x0000025bb7088b90>
> head(lapply(mtcars,pick(5)))
$mpg
[1] 18.7
$cyl
[1] 8
$disp
[1] 360
$hp
[1] 175
$drat
[1] 3.15
$wt
[1] 3.44
#检查结果
> head(lapply(mtcars,function(x) x[[5]]))
$mpg
[1] 18.7
$cyl
[1] 8
$disp
[1] 360
$hp
[1] 175
$drat
[1] 3.15
$wt
[1] 3.44
- 函数列表
#利用函数列表的思想比较三种不同方法计算平均值所需的时间
compute_mean <- list(
base = function(x) mean(x),
sum = function(x) sum(x) / length(x),
manual = function(x) {
total <- 0
n <- length(x)
for (i in seq_along(x)) {
total <- total + x[i] / n
}
total
}
)
x <- runif(1e5)
system.time(compute_mean$base(x))
#> user system elapsed
#> 0.001 0.000 0.001
system.time(compute_mean[[2]](x))
#> user system elapsed
#> 0.000 0.000 0.001
system.time(compute_mean[["manual"]](x))
#> user system elapsed
#> 0.023 0.000 0.023
> is.primitive(sum)
[1] TRUE
> is.primitive(mean)
[1] FALSE
#看看，元函数sum的快可见一斑。还有就是尽量避免使用循环，你看这个“manual”就慢的不像话
#lapply，让函数调用更简单
lapply(compute_mean, function(f) f(x))
#> $base
#> [1] 0.4994664
#>
#> $sum
#> [1] 0.4994664
#>
#> $manual
#> [1] 0.4994664
#如果需要额外的参数呢？有...在，你尽管放心加。
funs2 <- list(
sum = function(x, ...) sum(x, ..., na.rm = TRUE),
mean = function(x, ...) mean(x, ..., na.rm = TRUE),
median = function(x, ...) median(x, ..., na.rm = TRUE)
)
lapply(funs2, function(f) f(x))
#> $sum
#> [1] 55
#>
#> $mean
#> [1] 5.5
#>
#> $median
#> [1] 5.5
#当然还可以更简单
lapply(funs, function(f) f(x, na.rm = TRUE))
将函数列表移到全局环境
simple_tag <- function(tag) {
force(tag)
function(...) {
paste0("<", tag, ">", paste0(...), "</", tag, ">")
}
}
tags <- c("p", "b", "i")
html <- lapply(setNames(tags, tags), simple_tag)
html$p("This is ", html$b("bold"), " text.")
#> [1] "<p>This is <b>bold</b> text.</p>"
#三种方法终止html$的作用
1. with()，适合临时。最为推荐
with(html, p("This is ", b("bold"), " text."))
#> [1] "<p>This is <b>bold</b> text.</p>"
2. attach()，适合长时间。使用完成后，detach()解除即可
attach(html)
p("This is ", b("bold"), " text.")
#> [1] "<p>This is <b>bold</b> text.</p>"
detach(html)
3. list2env()，复制到全局环境
list2env(html, environment())
#> <environment: R_GlobalEnv>
p("This is ", b("bold"), " text.")
#> [1] "<p>This is <b>bold</b> text.</p>"
rm(list = names(html), envir = environment())
积分案例略
下课~
