编写函数是提高数据处理能力的最佳方法之一。与复制粘贴相比，函数能让你以更强大、更通用的方式自动执行常见任务。当我们对一个代码块进行3次或以上的复制+粘贴操作时，就应该考虑编写一个函数了。

我们主要学习3种最有用的函数：

向量函数(Section 1)：输入1个或多个向量，返回1个结果向量。
数据框函数(Section 2)：输入1个数据框，返回1个数据框。
绘图函数(Section 3)：输入1个数据框，返回图形。

library(tidyverse)
library(nycflights13)

1 向量函数-Vector functions

1.1 编写函数

分析重复的代码，找出哪些部分是不变的，哪些部分是变化的。将重复的部分写成初步函数。
分析函数主体部分，在可能的情况下改进函数的写法。
函数可以与mutate(),summarise()等函数结合使用。

# 给定一个出生日期向量，编写一个以年为单位计算年龄的函数
age_calculate <- function(birth_date) {
  # 计算年龄
  birth_date <- as.Date(birth_date)
  ages <- interval(birth_date, Sys.Date()) %/% years(1)
  return(ages)
}
## 测试函数
birthday <- c("1986-01-01", "1990-05", "2000-12-31")
age_calculate(birthday)

[1] 39 NA 24

# 编写一个接收两个长度相同的向量的函数，并返回这两个向量中都为NA的索引。
na_count <- function(x, y) {
  # 检查输入向量的长度是否相同
  if (length(x) != length(y)) {
    stop("输入向量的长度不相同")
  }
  # 计算 NA 的位置数
  na_pos <- which(is.na(x) & is.na(y))
  return(na_pos)
}
## 测试函数
x <- c(NA, 1, NA, 4, 5)
y <- c(NA, 2, 3, NA, 5)
na_count(x, y)

[1] 1

2 数据框函数-Data frame functions

在一个大型管道中，如果我们需要多次复制粘贴同一个变量名时，最好编写一个函数。
数据框函数的第一个参数通常是数据框，另外的参数则用来说明要对这个数据框做什么操作。

2.1 间接引用与整洁计算-Indirection and tidy evaluation

先来看一个例子：

# 分组并计算平均值
grouped_mean <- function(df, group_var, mean_var) {
  df %>%
    group_by(group_var) %>%
    summarise(mean(mean_var))
}

diamonds %>%
  grouped_mean(cut, price)

上面的代码会报错，因为在自定义函数中，group_var和mean_var是字符串，而不是变量名：我们需要使用{{}}（可以直观的理解为拥抱）来告诉R我们要使用的是变量名而不是字符串。

这个问题在单独进行计算时不会出现，只会在自定义函数中遇到。

对上述函数进行改写，就可以得到正确的结果。

grouped_mean <- function(df, group_var, mean_var) {
  df %>%
    group_by({{ group_var }}) %>% # 通过{{ group_var }} 传递变量名而不是字符串
    summarise(mean = mean({{ mean_var }}))
}
diamonds %>%
  grouped_mean(cut, price)

# A tibble: 5 × 2
  cut        mean
  <ord>     <dbl>
1 Fair      4359.
2 Good      3929.
3 Very Good 3982.
4 Premium   4584.
5 Ideal     3458.

2.2 什么时候需要使用`{{}}`？

数据屏蔽（Data-masking）：用于使用变量进行计算的函数中，例如arrange() 、group_by()、filter()和summarize()等。数据屏蔽内在的机制是先冻结表达式，然后注入函数，再恢复其计算，使得可以不用带数据框（环境变量）名字，就能使用数据框内的变量（数据变量），便于在数据框内计算值。
整洁选择(Tidy-select)：用于选择变量的函数，例如select() 、 relocate() 和 rename()等。即各种选择列语法，便于选择数据框中的列。

2.2.1 常见例子

下面我们看一下{{}}(整洁计算)的常见用法：

summary6 <- function(data, var) {
  data %>%
    summarise(
      across(
        {{ var }},
        list(
          mean = mean,
          sd = sd,
          min = min,
          max = max
        )
      ),
      n = n(),
      n_miss = sum(is.na(pick({{ var }}))),
      .groups = "drop"
    ) %>%
    as_tibble() %>%
    t()
}
diamonds %>%
  summary6(table)

                   [,1]
table_mean    57.457184
table_sd       2.234491
table_min     43.000000
table_max     95.000000
n          53940.000000
n_miss         0.000000

3 绘图函数-Plotting functions

ggplot()函数中的aes()是一个数据屏蔽（data-masking）函数。

histogram_plot <- function(df, var, binwidth = NULL) {
  df %>%
    ggplot(aes(x = {{ var }})) +
    geom_histogram(binwidth = binwidth)
}

diamonds %>%
  histogram_plot(carat, binwidth = 0.1)

# 通过叠加一条平滑线和一条直线来目测数据集是否是线性的：
linearity_cheak <- function(df, x, y) {
  df %>%
    ggplot(aes(x = {{ x }}, y = {{ y }})) +
    geom_point() +
    geom_smooth(method = "lm", formula = y ~ x, color = "red", se = F) +
    geom_smooth(method = "loess", formula = y ~ x, color = "blue", se = F)
}

starwars %>%
  filter(mass < 1000) %>%
  linearity_cheak(mass, height)

# 彩色散点图的替代方法，以解决超大数据集的过度绘图问题：
hex_plot <- function(df, x, y, z, bins = 20, fun = "mean") {
  df %>%
    ggplot(aes(x = {{ x }}, y = {{ y }}, z = {{ z }})) +
    stat_summary_hex(
      aes(color = after_scale(fill)), # 设定边界颜色与填充颜色相同
      bins = bins,
      fun = fun
    )
}

diamonds %>%
  hex_plot(carat, price, depth)

3.1 与其他tidyverse包结合使用

:=，被称为“walrus operator”，R语言中允许在该符号左侧使用变量名称。
ggplot()的强大功能可以让我们创造更多功能更复杂的函数。

# 在绘制条形图之前，对变量进行排序
sorted_bars <- function(df, var) {
  df %>%
    mutate({{ var }} := fct_rev(fct_infreq({{ var }}))) %>%
    ggplot(aes(y = {{ var }})) +
    geom_bar()
}

diamonds %>%
  sorted_bars(clarity)

3.2 在绘图函数中使用标签

现在我们来看看如何在绘图函数中使用标签。例如，我们希望在之前的histogram_plot()函数中添加标题，以显示binwidth的值：

ggplot2绘图中，我们可以在任何需要插入字符串的地方使用同样的方法

histogram_plot <- function(df, var, binwidth) {
  label <- rlang::englue("Histogram of {{var}} with binwidth {binwidth}")
  df %>%
    ggplot(aes(x = {{ var }})) +
    geom_histogram(binwidth = binwidth) +
    labs(title = label)
}

diamonds %>%
  histogram_plot(carat, binwidth = 0.1)

建议在{ } 内加入额外的空格，这样异常情况就会非常明显。style格式化可以完成这个操作。
函数的名称应该尽量简短和简洁，且能清晰的表达函数的功能。在使用的过程中，如果发现了更好的函数名称，应勇敢的修改函数名。
更多的函数建议风格，可参阅tidyverse style guide。

4 案例

4.1 案例1 一元二次方程求根

4.1.1 步骤

输入是什么？输出是什么？分别用什么数据结构存放？依次设计函数外形。
取一个具体的一元二次方程, $x^{2} - 3 x + 2 = 0$ ，作如下判断：

判断是否为一元二次方程，若不是返回NULL，并输出警告信息。
如果是，根据跟判别式判断根的情况，并分三种情况按照求根公式完成计算。

4.1.2 code

quad_eq <- function(coefs) {
  a <- coefs[1]
  b <- coefs[2]
  c <- coefs[3] # 设定系数
  # 判断是否为一元二次方程的条件
  if (a == 0) {
    warning("不是一元二次方程")
    return(NULL)
  }
  ## 计算根
  delta <- b^2 - 4 * a * c
  if (delta > 0) {
    (-b + c(1, -1) * delta) / (2 * a)
  } else if (delta == 0) {
    -b / (2 * a)
  } else {
    (-b + c(1, -1) * sqrt(-delta) * 1i) / (2 * a)
  }
}

# 单独测试
quad_eq(c(1, -3, 2))

[1] 2 1

quad_eq(c(0, 2, 3))

NULL

# 批量测试
eqs <- list(c(0, 2, 3), c(1, -3, 2), c(1, -2, 1), c(1, 1, 2), c(3, 4, 5))
rlt <- map(
  eqs,
  \(x) quad_eq(x)
)
rlt

[[1]]
NULL

[[2]]
[1] 2 1

[[3]]
[1] 1

[[4]]
[1] -0.5+1.322876i -0.5-1.322876i

[[5]]
[1] -0.6666667+1.105542i -0.6666667-1.105542i

4.2 案例2 计算BMI与肥胖类型

# 模拟一个人的计算
height <- 175
weight <- 70
BMI <- weight / (height / 100)^2
type <- case_when(
  BMI >= 28 ~ "肥胖",
  BMI > 24 ~ "超重",
  BMI >= 18.5 ~ "正常",
  .default = "偏瘦"
)

data.frame(BMI = BMI, type = type)

       BMI type
1 22.85714 正常

# 编写批量计算函数
# 输入为身高和体重的数值，输出为BMI和肥胖类型的数据框
Cal_BMI <- function(height, weight) {
  BMI <- weight / (height / 100)^2
  type <- case_when(
    BMI >= 28 ~ "肥胖",
    BMI > 24 ~ "偏胖",
    BMI >= 18.5 ~ "正常",
    .default = "偏瘦"
  )

  data.frame(BMI = BMI, type = type)
}
Cal_BMI(175, 75)

      BMI type
1 24.4898 偏胖

4.3 案例3 将数据框每行最后一个非NA值替换为NA

每一行是一个向量
调试：关键要定位最后一个非NA值的位置
编写函数
逐行迭代

df <- tribble(
  ~a,
  ~b,
  ~c,
  ~d,
  1,
  2,
  3,
  NA,
  1,
  NA,
  NA,
  NA,
  1,
  2,
  NA,
  NA,
  NA,
  NA,
  NA,
  NA
)
df

# A tibble: 4 × 4
      a     b     c d    
  <dbl> <dbl> <dbl> <lgl>
1     1     2     3 NA   
2     1    NA    NA NA   
3     1     2    NA NA   
4    NA    NA    NA NA

# 将数据框每行最后一个非NA值替换为NA
replace_last_na <- function(row) {
  no_na_pos <- which(!is.na(row))
  if (length(no_na_pos) == 0) {
    return(row)
  }
  last_pos <- max(no_na_pos)
  row[last_pos] <- NA
  return(row)
}

pmap_dfr(df, \(...) replace_last_na(c(...)))

# A tibble: 4 × 4
      a     b     c     d
  <dbl> <dbl> <dbl> <dbl>
1     1     2    NA    NA
2    NA    NA    NA    NA
3     1    NA    NA    NA
4    NA    NA    NA    NA