- 参考：
- 《R 的极客理想 高级开发篇》
- 《R inferno》
- Introduction | Advanced R (hadley.nz)[1]
前言
硬着头皮看完了S3。以我浅薄的认知来说，S3 挺没必要学的，大概了解下，会用就行了QAQ。
简介
之前的部分，我们对R 的面向对象有了一个大致的了解。这里，我们追随R 的发展步伐，由易到难，由简入繁，先从S3 开始。
S3 对象虽然像是一台为了OOP 特性临时拼凑的一台轿车，但是你不得不承认，它极简地非常厉害：S3 对象中的每一个部分都缺一不可，刚刚好。
如果一个java 开发者，看到了S3 风格的代码，他可能会头疼；但是，你是一个灵活的R 工作者，自由和洒脱是你的天性。
从S3 对象的定义你就能窥见一斑：S3 对象仅仅是base type 加上一个class 属性。
比如factor 就是一个S3 对象：
代码语言：javascript复制tmp <- factor(c("a", "b", "c"))
> attributes(tmp)
$levels
[1] "a" "b" "c"
$class
[1] "factor"
> otype(tmp)
[1] "S3"
1-基础
我们也可以自己定义一个S3 对象。
代码语言：javascript复制my_S3 <- "test"
class(my_S3) <- "good"
otype(my_S3)
[1] "S3"
如何获得S3 对象中的base type 呢，可以通过函数unclass：
unclass(f)
#> [1] 1 2 3
#> attr(,"levels")
#> [1] "a" "b" "c"
2-泛型函数
S3 对象不同于base type 的主要区别在于其作为参数输入泛型函数（generic），我们可以通过sloop 包中的ftype 来查看函数是否是泛型的：
代码语言：javascript复制ftype(print)
#> [1] "S3" "generic"
ftype(str)
#> [1] "S3" "generic"
ftype(unclass)
#> [1] "primitive"
在[[104-R茶话会19-几种查看函数源代码的方法]] 我们就提过几种查看泛型函数的代码的操作。比如我们经常使用的print 函数，其实也是个泛型函数：
代码语言：javascript复制> print
function (x, ...)
UseMethod("print")
<bytecode: 0x7fd098c96120>
<environment: namespace:base>
> print.default
function (x, digits = NULL, quote = TRUE, na.print = NULL, print.gap = NULL,
right = FALSE, max = NULL, width = NULL, useSource = TRUE,
...)
{
args <- pairlist(digits = digits, quote = quote, na.print = na.print,
print.gap = print.gap, right = right, max = max, width = width,
useSource = useSource, ...)
missings <- c(missing(digits), missing(quote), missing(na.print),
missing(print.gap), missing(right), missing(max), missing(width),
missing(useSource))
.Internal(print.default(x, args, missings))
}
<bytecode: 0x7fd098cbdf60>
<environment: namespace:base>
p：在中文世界，需要区分泛型函数（generic）和泛函（functionals）的差别。关于后者，可以参见：19 函数进阶 | R语言教程[2]
泛型函数就像是一个工具人，它的任务就是给S3 对象找到合适的工具（implementation），对应具体的class 的工具就是方法，这个过程也被叫做 method dispatch：
代码语言：javascript复制> methods(summary)
[1] summary.aov summary.aovlist*
[3] summary.aspell* summary.check_packages_in_dir*
[5] summary.connection summary.data.frame
[7] summary.Date summary.default
[9] summary.ecdf* summary.factor
[11] summary.glm summary.infl*
[13] summary.lm summary.loess*
[15] summary.manova summary.matrix
[17] summary.mlm* summary.nls*
[19] summary.packageStatus* summary.POSIXct
[21] summary.POSIXlt summary.ppr*
[23] summary.prcomp* summary.princomp*
[25] summary.proc_time summary.rlang_error*
[27] summary.rlang_trace* summary.srcfile
[29] summary.srcref summary.stepfun
[31] summary.stl* summary.table
[33] summary.tukeysmooth* summary.warnings
see '?methods' for accessing help and source code
我们可以使用sloop::s3_dispatch() 解析这个过程：
s3_dispatch(print(f))
#> => print.factor
#> * print.default
3-class属性
如py 等OOP，都会对类有严格的定义，并通过类的实例化来创建对象。而在R 的S3 对象中，一切就显得简单而枯燥起来了，就像上面说的，仅仅是给base type 添加一个class 属性，它就是这个类的实例化对象了：
代码语言：javascript复制# Create and assign class in one step
x <- structure(list(), class = "my_class")
# Create, then set class
x <- list()
class(x) <- "my_class"
p：按照我的理解，在S3 系统中，并不存在类对象，类仅仅是通过属性设置的一种“标签”。
同样我们也可以查看某个对象是否是属于某个类：
代码语言：javascript复制class(x)
#> [1] "my_class"
inherits(x, "my_class")
#> [1] TRUE
inherits(x, "your_class")
#> [1] FALSE
不仅S3 的类实例创建非常的简单，我们可以直接对class 属性重新赋值来修改对象所属于的类：
代码语言：javascript复制# Create a linear model
mod <- lm(log(mpg) ~ log(disp), data = mtcars)
class(mod)
#> [1] "lm"
print(mod)
#>
#> Call:
#> lm(formula = log(mpg) ~ log(disp), data = mtcars)
#>
#> Coefficients:
#> (Intercept) log(disp)
#> 5.381 -0.459
# Turn it into a date (?!)
class(mod) <- "Date"
# Unsurprisingly this doesn't work very well
print(mod)
#> Error in as.POSIXlt.Date(x): 'list' object cannot be coerced to type 'double'
如果说其他严格的面向对象的系统是一把枪的话，其严格的规定了哪些东西可以打，哪些东西不能打；而S3 则是啥也没规定，你想用它崩了你的脑门，也没有关系。
但为了防止你崩了自己的脑门，下面有三个关于S3 的规范：
- A low-level constructor, new_myclass(), that efficiently creates new objects with the correct structure.
- A validator, validate_myclass(), that performs more computationally expensive checks to ensure that the object has correct values.
- A user-friendly helper, myclass(), that provides a convenient way for others to create objects of your class.
最关键的是第一个建造器，constructor。
比如我们可以手写一个创建Date 类的函数，其包括了三个原则：
- Be called new_myclass().
- Have one argument for the base object, and one for each attribute.
- Check the type of the base object and the types of each attribute.
new_Date <- function(x = double()) {
stopifnot(is.double(x))
structure(x, class = "Date")
}
new_Date(c(-1, 0, 1))
#> [1] "1969-12-31" "1970-01-01" "1970-01-02"
对应于建造器函数new_**，还可以增加一个函数 validator，其形如validate_**。
validate_factor <- function(x) {
values <- unclass(x)
levels <- attr(x, "levels")
if (!all(!is.na(values) & values > 0)) {
stop(
"All `x` values must be non-missing and greater than zero",
call. = FALSE
)
}
if (length(levels) < max(values)) {
stop(
"There must be at least as many `levels` as possible values in `x`",
call. = FALSE
)
}
x
}
validate_factor(new_factor(1:5, "a"))
#> Error: There must be at least as many `levels` as possible values in `x`
validate_factor(new_factor(0:1, "a"))
#> Error: All `x` values must be non-missing and greater than zero
最终，为了让用户可以方便创建类的对象，最好写一个helper 函数，其打包了建造器及验证器，并有如下规范：
- 函数名和类相同；
- 其输出是建造器和验证器的组合；
- 对于各种error 产生的异常有明确的错误提示；
- 周全的传参及类型转换设定。
比如下面是factor 的helper：
代码语言：javascript复制factor <- function(x = character(), levels = unique(x)) {
ind <- match(x, levels)
validate_factor(new_factor(ind, levels))
}
factor(c("a", "a", "b"))
#> [1] a a b
#> Levels: a b
4-我的第一个S3类
尝试通过上面的规范，我们来创建一个animal 类吧。
代码语言：javascript复制##################################################
## Project: Rescue the Princess
## File name: 03-S3.R
## Date: Tue Apr 12 10:17:00 2022
## Author: Peng
## Email: mugpeng@foxmail.com
## R_Version: R version 4.0.5 (2021-03-31)
## R_Studio_Version: 1.4.1106
## Platform Version: macOS Big Sur 10.16
##################################################
# constructor----
new_animal <- function(x = character(), age = numeric(),
gender = logical()) {
stopifnot(is.character(x))
stopifnot(is.numeric(age))
stopifnot(is.logical(gender))
structure(
x,
age = age,
gender = gender,
class = "animal"
)
}
# validator ----
validate_animal <- function(x) {
# values <- unclass(x)
attribute_x <- attributes(x)
# attribute_x <- attribute_x[!names(attribute_x) %in% "class"]
if (length(x) != 1) {
stop(
"object length must be equal to 1.",
call. = FALSE
)
}
lapply(attribute_x, function(y){
if (length(y) != 1) {
stop(
"Attribute length must be equal to 1.",
call. = FALSE
)
}
})
x
}
# helper ----
animal <- function(x = "dog", age = 3L, gender = T) {
validate_animal(new_animal(x, age, gender))
}
a1 <- animal()
a2 <- animal(c("dog","cat"))
5-泛型函数method dispatch 过程
上面提到过，泛型函数就像是一个工具人，它的任务就是给S3 对象找到合适的工具（implementation），对应具体的class 的工具就是方法，这个过程也被叫做 method dispatch。
大部分的泛型函数的method dispatch 实现过程都非常简单，也就是在每次调用泛型函数的时候，都调用UseMethod 方法，比如泛型函数mean ：
mean
#> function (x, ...)
#> UseMethod("mean")
#> <bytecode: 0x7f9682af1668>
#> <environment: namespace:base>
★You don’t pass any of the arguments of the generic to UseMethod(); it uses deep magic to pass to the method automatically. The precise process is complicated and frequently surprising, so you should avoid doing any computation in a generic. To learn the full details, carefully read the Technical Details section in ?UseMethod. ”
UseMethod 会创建一个关于方法名称的向量：
代码语言：javascript复制paste0("generic", ".", c(class(x), "default"))
接下来，它会寻找是否存在这些方法。
比如函数 sloop::s3_dispatch() 就动态输出了UseMethod 函数method dispatch 的过程：
x <- Sys.Date()
s3_dispatch(print(x))
#> => print.Date
#> * print.default
=>indicates the method that is called, here print.Date()*indicates a method that is defined, but not called, here print.default().
需要注意的是，这里的default 并非是一个存在的类，其目的是为了当使用的类并不存在一个对应的方法的时候，至少有一个“保底”的函数输出。
sloop 包也提供了一些函数去寻找泛型函数对应的类，以及不同类对应的泛型函数：
代码语言：javascript复制s3_methods_generic("mean")
#> # A tibble: 7 x 4
#> generic class visible source
#> <chr> <chr> <lgl> <chr>
#> 1 mean Date TRUE base
#> 2 mean default TRUE base
#> 3 mean difftime TRUE base
#> 4 mean POSIXct TRUE base
#> 5 mean POSIXlt TRUE base
#> 6 mean quosure FALSE registered S3method
#> 7 mean vctrs_vctr FALSE registered S3method
s3_methods_class("ordered")
#> # A tibble: 4 x 4
#> generic class visible source
#> <chr> <chr> <lgl> <chr>
#> 1 as.data.frame ordered TRUE base
#> 2 Ops ordered TRUE base
#> 3 relevel ordered FALSE registered S3method
#> 4 Summary ordered TRUE base
6-创建泛型函数
R advanced 中，作者提出了两点注意：
- 虽然S3系统并不会限制我们给这些对象创建函数，但我们只给那些我们创建的类写generic；（尊重问题，如果想增加新方法，可以给作者发邮件）；
- generic 的参数需和对象拥有相同的参数，A method must have the same arguments as its generic. This is enforced in packages by R CMD check, but it’s good practice even if you’re not creating a package.
p：这个same argument 该如何理解呢？
创建泛型函数，我们需要通过UseMethod 定义类型，接下来以generic.class 的方式命名这些方法，对应指定的类。
我们可以创建一个泛型函数，并设置一个专门类的方法，以及一个default方法：
代码语言：javascript复制dog <- structure("cat", class = "animal")
human <- structure("cat", class = "human")
apple <- "apple"
bark <- function(x, ...) UseMethod("bark")
bark.animal <- function(x, ...) print("AHHH WOOOO~")
bark.human <- function(x, ...) print("GEGEDA~")
bark.default <- function(x, ...) print("Emmmmm~")
bark(apple)
bark(animal)
猜猜看各自的输出是什么。
我们还可以用先前使用的sloop包中的函数，来追踪methods dispatch 的过程：
代码语言：javascript复制> sloop::s3_dispatch(bark(dog))
=> bark.animal
* bark.default
需要注意的是，如果这里的泛型函数会使用其他参数，UseMthod 方法所在的函数需要创建为不定长函数，也就是参数末尾加上...:
bark <- function(x, ...)
7-继承
S3 类提供了继承（inheritance）机制。
class 可以由字符串类型的向量构成。这同样表示，一个S3 对象可以有多个类属性，通过向量表示：
代码语言：javascript复制class(ordered("x"))
#> [1] "ordered" "factor"
class(Sys.time())
#> [1] "POSIXct" "POSIXt"
如果这个S3 对象按照顺序的第一个类没有找到对应的方法，R 会依次寻找：
代码语言：javascript复制s3_dispatch(ordered("x")[1])
#> [.ordered
#> => [.factor
#> [.default
#> -> [ (internal)
这个ordered 类总是在factor类的后面，因此其被称为子类（subclass），而factor 则对应为它的父类（superclass）。
虽然S3 没有严格的限制类的继承，但最好遵守：
- 子类和父类的base type 应该保持一致；
- 父类的属性应该是子类属性的子集。
7.1-NextMethod 方法
假设我们现在创建了一个属于secret类的变量：
new_secret <- function(x = double()) {
stopifnot(is.double(x))
structure(x, class = "secret")
}
print.secret <- function(x, ...) {
print(strrep("x", nchar(x)))
invisible(x)
}
x <- new_secret(c(15, 1, 456))
x
#> [1] "xx" "x" "xxx"
通过配置print 方法，我们创建的新的类的对象获得了指定的输出。
然而，默认的取子集的[方法并不会识别这个新类：
s3_dispatch(x[1])
#> [.secret
#> [.default
#> => [ (internal)
x[1]
#> [1] 15
重新创建[ 函数，通过解类x 再重新创建新对象，可以达到目的：
`[.secret` <- function(x, i) {
x <- unclass(x)
new_secret(x[i])
}
x[1]
#> [1] "xx"
如果是下面这种：
代码语言：javascript复制`[.secret` <- function(x, i) {
new_secret(x[i])
}
为什么会是这样呢：
代码语言：javascript复制r$> x[1]
错误: C stack usage 7972000 is too close to the limit
这时候就可以使用NextMethod()了：
`[.secret` <- function(x, i) {
new_secret(NextMethod())
}
x[1]
#> [1] "xx"
s3_dispatch(x[1])
#> => [.secret
#> [.default
#> -> [ (internal)
虽然我们使用了[.secret 方法，但实际上其调用的是[ (internal)，相当于先对向量取了子集，接下来让这个子集创建对象，并输出。
7.2-S3系统的子类
我们可以通过不定长参数，为对象的创建引入多个类：
代码语言：javascript复制new_secret <- function(x, ..., class = character()) {
stopifnot(is.double(x))
structure(
x,
...,
class = c(class, "secret")
)
}
接下来可以创建子类的函数以引入新的子类：
代码语言：javascript复制new_supersecret <- function(x) {
new_secret(x, class = "supersecret")
}
print.supersecret <- function(x, ...) {
print(rep("xxxxx", length(x)))
invisible(x)
}
x2 <- new_supersecret(c(15, 1, 456))
x2
#> [1] "xxxxx" "xxxxx" "xxxxx"
但当我们据需使用[ 方法时，其只会返回之前设置的父类的方法：
`[.secret` <- function(x, ...) {
new_secret(NextMethod())
}
x2[1:3]
#> [1] "xx" "x" "xxx"
这里哈雷德提出R 基础并不能解决，给出了vctrs 包以解决这个问题：
代码语言：javascript复制vec_restore.secret <- function(x, to, ...) new_secret(x)
vec_restore.supersecret <- function(x, to, ...) new_supersecret(x)
首先指定父类和子类对应的方法。
接下来在对应的方法中调用vec_restore，其就会根据类自动识别了：
`[.secret` <- function(x, ...) {
vctrs::vec_restore(NextMethod(), x)
}
x2[1:3]
#> [1] "xxxxx" "xxxxx" "xxxxx"
参考资料
[1]
Introduction | Advanced R (hadley.nz): https://adv-r.hadley.nz/oo.html
[2]
19 函数进阶 | R语言教程: https://www.math.pku.edu.cn/teachers/lidf/docs/Rbook/html/_Rbook/p-advfunc.html#p-advfunc-functional
