进阶 R 与工程化：GxP 级代码

SAS 老兵不怕写代码，怕的是写出"别人不敢审计"的代码。本章把 R 打磨成 GxP 级：函数式编程、作用域、S3、性能、错误与日志、单元测试、CI、验证框架、评审清单——九步走完，你的 R 代码就有资格进递交证据链。

5.1 函数式编程：purrr::map 家族

处理"一批数据集"，你的 SAS 肌肉记忆是 %macro + %do；R 的答案是函数式编程：函数是一等公民，可以像变量一样装进列表、当参数传递。purrr::map 家族就是类型安全、管道友好的批量迭代器：map 永远返回列表；确定返回类型时用 map_lgl / map_chr / map_dbl；两个输入用 map2、多个用 pmap；结果列表用 list_rbind() 纵向拼表。

suppressPackageStartupMessages({ library(dplyr); library(purrr) })

# 三个中心的 ADSL 分片（列表 of data.frame）
adsl_by_site <- list(
  site01 = tibble(site = "01", age = c(63, 71, 58), sex = c("M", "F", "F")),
  site02 = tibble(site = "02", age = c(45, 52),     sex = c("M", "M")),
  site03 = tibble(site = "03", age = c(66, 48, 55, 61), sex = c("F", "M", "F", "M"))
)

# SAS 思路：%do 遍历中心 + proc means；R：一个 map 搞定
summ <- adsl_by_site |>
  map(\(df) df |> summarise(n = n(), mean_age = round(mean(age), 1), .by = site))

list_rbind(summ)

# 匿名函数：R 4.1+ 的 \(x) 简写，等价于 function(x)
map_dbl(1:4, \(x) x * 2)

# 实跑捕获（R 4.5.0）
# A tibble: 3 x 3
  site      n mean_age
  <chr> <int>    <dbl>
1 01        3     64  
2 02        2     48.5
3 03        4     57.5
[1] 2 4 6 8

5.2 环境与作用域：闭包

R 的每个函数在定义处携带一个环境：调用时去哪儿找变量名，由它在哪定义决定，而不是在哪被调用——这叫词法作用域。闭包 = 函数 + 它的出生环境，是 R 里"保存私有状态"的正规姿势。

make_counter <- function() {
  n <- 0                       # n 被封在函数环境里
  function() {                 # 返回的匿名函数记住出生地
    n <<- n + 1                # <<- 只改父环境（闭包环境）的 n
    n
  }
}

c1 <- make_counter()
c2 <- make_counter()           # 第二个闭包，互不干扰

cat(c1(), c1(), c2(), c1(), "\n")
cat("全局环境里没有 n：", exists("n", envir = globalenv()), "\n")

# 实跑捕获（R 4.5.0）
1 2 1 3 
全局环境里没有 n： FALSE

5.3 S3 十分钟：给对象贴上类

S3 是 R 最轻量的对象系统：给对象贴一个 class 属性，print、summary、format 这类泛型函数就会按类自动分发到你写的方法。不需要正式的类定义文件，十分钟上手。

x <- list(study = "STUDY01", n = 128, vars = c("AGE", "SEX", "RACE"))
class(x) <- "adsl_report"      # 一行贴上 S3 类标签

# 方法名 = 泛型.类名，print() 会自动分发过来
print.adsl_report <- function(x, ...) {
  cat("== ADSL Report ==\n")
  cat("Study:", x$study, "\n")
  cat("N    :", x$n, "\n")
  cat("Vars :", paste(x$vars, collapse = ", "), "\n")
  invisible(x)
}

print(x)                       # 无需手工调用 print.adsl_report
cat("class(x) =", class(x), "\n")

# 实跑捕获（R 4.5.0）
== ADSL Report ==
Study: STUDY01 
N    : 128 
Vars : AGE, SEX, RACE 
class(x) = adsl_report

5.4 性能：向量化优先

SAS 用户写 R 最容易卡壳的地方：把 DATA step 的逐行思维直译成 for 循环。R 的循环每一步都经过解释器、还伴随"修改即复制"；向量化函数底层是编译好的 C 循环。让 100 万行数据说话：

set.seed(42)
n <- 1e6
df <- data.frame(age = rnorm(n))       # 100 万行"受试者年龄"
m  <- matrix(df$age, nrow = 1000)      # 1000 x 1000 矩阵，同一批数据

cat("-- 反模式：逐行 for，每圈还重新抽列 --\n")
print(system.time({ s1 <- 0; for (i in seq_len(nrow(df))) s1 <- s1 + df$age[i] }))

cat("-- 向量化 sum() --\n")
print(system.time({ s2 <- sum(df$age) }))

cat("-- 列和 colSums() --\n")
print(system.time({ s3 <- colSums(m) }))

cat("三种算法结果一致:",
    isTRUE(all.equal(s1, s2)),
    isTRUE(all.equal(sum(s3), s2)), "\n")

# 实跑捕获（R 4.5.0）
-- 反模式：逐行 for，每圈还重新抽列 --
   user  system elapsed 
   0.61    0.00    0.63 
-- 向量化 sum() --
   user  system elapsed 
      0       0       0 
-- 列和 colSums() --
   user  system elapsed 
      0       0       0 
三种算法结果一致: TRUE TRUE

5.5 错误与日志：tryCatch、withCallingHandlers、logger

SAS 有 ERROR/WARNING 的日志纪律；R 的对应物是条件系统：error（中断）、warning（警示）、message（提示），外加两种捕获姿势——tryCatch 与 withCallingHandlers——以及生产级日志包 logger。

derive_agegrp <- function(rfstdtc) {
  if (is.na(rfstdtc)) {
    warning("RFSTDTC missing, returning NA")
    return(NA_real_)
  }
  as.numeric(substr(rfstdtc, 1, 4)) - 1960
}

# tryCatch：handler 在调用者环境执行，原调用已经退出
r1 <- tryCatch(derive_agegrp(NA),
               warning = function(w) {
                 cat("tryCatch 捕获:", conditionMessage(w), "\n")
                 NA_real_
               })

# withCallingHandlers：handler 在现场执行，可用 restart 让代码继续
r2 <- withCallingHandlers(
  derive_agegrp(NA),
  warning = function(w) {
    cat("handler 现场看到:", conditionMessage(w), "\n")
    invokeRestart("muffleWarning")   # 按下警告，函数继续跑完
  })

cat("r1 =", r1, "; r2 =", r2, "\n")

suppressPackageStartupMessages(library(logger))
log_formatter(formatter_sprintf)   # 默认是 glue 风格 {}，此处用 %s 演示
log_threshold(INFO)
log_info("derive_agegrp 开始，输入 n = %s", 100)
log_error("RFSTDTC 格式非法: %s", "2015-13-45")

# 实跑捕获（R 4.5.0）
tryCatch 捕获: RFSTDTC missing, returning NA 
handler 现场看到: RFSTDTC missing, returning NA 
r1 = NA ; r2 = NA 
INFO [2026-09-16 23:51:50] derive_agegrp 开始，输入 n = 100
ERROR [2026-09-16 23:51:50] RFSTDTC 格式非法: 2015-13-45

5.6 testthat：把 QC 写成断言

双编程很贵；testthat 把"QC 的另一半"机器化：每条派生规则写成可执行断言，改完代码一条命令全量回归。它也是第 6 章包开发与 5.7 CI 的地基。

library(testthat)

derive_age <- function(birth_year, ref_year) {
  if (!is.numeric(birth_year)) stop("birth_year must be numeric")
  ref_year - birth_year
}

with_reporter(ProgressReporter$new(show_praise = FALSE), {
  test_that("derive_age 正确", {
    expect_equal(derive_age(1960, 2024), 64)
    expect_error(derive_age("1960", 2024))
  })
})

# 实跑捕获（R 4.5.0）
v | F W  S  OK | Context
- |          1 |
== Results =====================================================================
[ FAIL 0 | WARN 0 | SKIP 0 | PASS 2 ]

5.7 CI：GitHub Actions 上的持续回归

CI（持续集成）= 每次 git push，云端机器自动替你跑一遍 5.6 的回归测试，日志自动存档。对 GxP 团队，它的真实价值是：把验证从"一次性事件"变成"每次提交都有时间戳的持续证据"。GitHub Actions 是事实标准，一个 YAML 文件就够：

# .github/workflows/check.yaml —— 每次 push 自动回归
on:
  push:
    branches: [main, develop]
  pull_request:
    branches: [main]

jobs:
  check:
    runs-on: ubuntu-latest
    env:
      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
    steps:
      - uses: actions/checkout@v4

      - uses: r-lib/actions/setup-r@v2
        with:
          use-public-rspm: true      # 用 Posit 公共镜像装包，提速

      - uses: r-lib/actions/setup-renv@v2   # 按 renv.lock 复原锁定环境

      - uses: r-lib/actions/check-r-package@v2  # R CMD check + testthat 全量回归

5.8 GxP 验证：valtools 工作流与 CSV 映射

第 0 章说过：在 R 世界，验证的最小单元是"包 + 测试 + 锁环境"，而不是单个脚本。落到工具上，pharmaverse/PHUSE 社区开源的 valtools（pharmaverse.github.io/valtools）把 CSV 纪律搬进了 R 项目：用 vt_create_skeleton() 生成验证工程骨架（验证计划、需求、风险分析各就各位）；需求、代码、测试同库管理，形成需求→代码→测试的追溯矩阵；最后 vt_create_report() 一键产出带追溯关系的验证报告。你在 SAS 时代的 VP/IQ/OQ/PQ 文档树，几乎可以逐层映射过去：

5.9 代码评审清单：10 条硬杠

把下面的清单贴在 PR 模板里，评审时逐条打勾——这就是 R 版的"程序审阅 sign-off"：

1. 命名：函数/文件遵循团队规范（derive_* / tfl_* 前缀、snake_case），名字即用途。
2. spec 链接：程序头或 roxygen 注释里给出映射规格（spec）链接与需求编号，可回溯。
3. 无硬编码：研究号、路径、日期一律来自配置或参数；不出现 "C:/Users/..." 式绝对路径。
4. NA 处理：join 键缺失、日期缺失、分母为零的行为被显式处理并在注释里说明。
5. 键唯一性断言：对 USUBJID 等主键有 stopifnot(!anyDuplicated(...)) 或断言包检查。
6. 日志：关键步骤有 logger/message 输出并可落盘，级别足以还原运行过程。
7. 测试覆盖：每个派生函数至少一正（expect_equal）一负（expect_error）两条 testthat 断言。
8. renv 锁：新增依赖后跑过 renv::snapshot()，renv.lock 随 PR 一起提交评审。
9. sessionInfo 留存：正式运行的输出附 sessionInfo()，与产物、日志一并归档。
10. 双人复核点：merge 逻辑、人群划分、分母定义等 QC 关键点标记"需第二人复核"，留复核记录。

章末资源

本章练习

1. （易）挑你项目里现有的一个派生函数，补两条 testthat 断言：一条 expect_equal 验证正确输入，一条 expect_error 验证非法输入必须抛错。
2. （中）给一个完整脚本加上 logger 三级日志：开始/关键步骤用 log_info，可疑数据用 log_warn，致命失败用 log_error，并用 appender_to_file 落盘。
3. （难）为练习 2 的脚本写一个 GitHub Actions workflow：push 触发，setup-r + setup-renv 复原环境，跑通 testthat 全量回归，直到 CI 全绿。

下一章：把散落各处的 derive_* 函数收编成真正的 R 包——roxygen 文档、tests 目录、R CMD check 与内部包发布流程，让 5.8 的验证框架有物可验。