R包开发：自定义S3 print方法赋值时自动打印摘要问题

问题根源 #

R的底层运行规则是：仅当顶层调用的返回值处于可见状态时，才会自动触发对应类的S3 print方法。赋值操作（<-/=）会将右侧表达式的返回值标记为不可见，因此赋值时不会自动触发print，和现有S3方法的编写逻辑无关。

现有代码 #

当前函数与S3打印方法实现如下：

fun_example <- function(xvar, yvar){
  # 生成绘图对象
  plot1 = ggplot2::ggplot(data.frame(xvar, yvar), ggplot2::aes(x = xvar, y = yvar)) + ggplot2::geom_line()
  plot2 = ggplot2::ggplot(data.frame(xvar, yvar), ggplot2::aes(x = xvar, y = yvar)) + ggplot2::geom_line()
  plots <- list(plot1, plot2)
  
  # 计算相关系数
  Cor <- cor(xvar, yvar)
  
  result <- list(plots, Cor)
  names(result) <- c("plots", "Cor")
  class(result) <- "fun_example"
  suppressMessages(return(result))
}

#-------------------------------------------
## S3 print方法 // 更新于2021.02.06
#-------------------------------------------
#' S3打印方法
#' @aliases print.fun_example
#' @usage \method{print}{fun_example}(x, ...)
#' @description 针对package_example包对象的打印方法
#' @param x package_example包生成的对象
#' @param ... 额外传入参数
#' @return 打印fun_example类对象的摘要信息
#' @export
print.fun_example <- function(x, ...){
  cat("请逐一检查plots对象中的每张图，判断变量间是否存在线性关系。\n")
  if(x$Cor > 0.8){
    cat("检测到变量相关系数大于0.8。")
  } else {
    cat("检测到变量相关系数小于等于0.8。")
  }
}

需求说明 #

• 直接运行函数不赋值时，自定义print正常触发，符合预期
• 要求将函数返回结果赋值给对象时，控制台自动输出预设的自定义摘要
• 禁止直接在函数内部硬编码打印语句，必须通过已实现的S3 print.fun_example方法完成输出

实现方案 #

采用延迟触发逻辑，完全复用现有S3打印方法，无硬编码打印内容，不影响函数在非顶层、非全局环境的调用逻辑。

方案1：轻量钩子实现（推荐） #

在fun_example函数构造完返回对象、执行return前加入如下逻辑，检测到全局环境下的顶层赋值操作时，注册退出钩子，等赋值完成后自动调用已有的S3 print方法：

# 以下代码放在result构造完成、return(result)之前
if (identical(parent.frame(), globalenv())) {
  current_call <- sys.call()
  # 识别赋值操作
  if (as.character(current_call[[1]]) %in% c("<-", "=")) {
    on.exit({
      # 等当前调用栈执行完毕（赋值完成）后触发打印
      later::later(function() {
        obj_name <- as.character(current_call[[2]])
        if (exists(obj_name, envir = globalenv(), inherits = FALSE)) {
          current_obj <- get(obj_name, envir = globalenv(), inherits = FALSE)
          # 仅对目标类触发打印，避免误触发
          if (inherits(current_obj, "fun_example")) {
            print(current_obj)
          }
        }
      }, delay = 0)
    }, add = TRUE)
  }
}

注意事项

• 该逻辑仅在用户直接在全局环境调用函数赋值时触发，函数嵌套调用、其他包调用该函数时不会额外触发打印
• 所有打印逻辑完全走已写好的print.fun_example方法，后续修改打印规则只需要调整S3方法即可，不需要改动主函数逻辑
• 若不想引入later包作为依赖，可采用方案2的无依赖实现

方案2：无依赖任务回调实现 #

在包的加载钩子.onLoad中注册全局任务回调，监听全局环境中新生成的fun_example类对象，自动触发S3打印：

# 写在包的zzz.R文件中
.onLoad <- function(libname, pkgname) {
  # 注册任务回调
  addTaskCallback(function(expr, value, ok, visible) {
    # 识别赋值操作
    if (is.call(expr) && as.character(expr[[1]]) %in% c("<-", "=")) {
      obj_name <- as.character(expr[[2]])
      if (exists(obj_name, envir = globalenv(), inherits = FALSE)) {
        obj <- get(obj_name, envir = globalenv(), inherits = FALSE)
        # 仅对第一次生成的目标类对象触发打印
        if (inherits(obj, "fun_example") && !identical(attr(obj, "printed"), TRUE)) {
          print(obj)
          # 加标记避免重复打印
          attr(obj, "printed") <- TRUE
          assign(obj_name, obj, envir = globalenv())
        }
      }
    }
    # 保持回调持续生效
    TRUE
  })
}

该方案完全不需要依赖第三方包，仅在包加载时注册一次回调即可，同样完全复用现有S3打印方法。

内容的提问来源于stack exchange，提问作者Laura Jamison