129-R编程22-找对象之S3对象与泛型函数

北野茶缸子

发布于 2022-05-19 11:33:27

8830

发布于 2022-05-19 11:33:27

文章被收录于专栏：北野茶缸子的专栏

参考：
- 《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 对象：

tmp <- factor(c("a", "b", "c"))

> attributes(tmp)
$levels
[1] "a" "b" "c"

$class
[1] "factor"

> otype(tmp)
[1] "S3"

1-基础

我们也可以自己定义一个S3 对象。

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 来查看函数是否是泛型的：

ftype(print)
#> [1] "S3"      "generic"
ftype(str)
#> [1] "S3"      "generic"
ftype(unclass)
#> [1] "primitive"

在[[104-R茶话会19-几种查看函数源代码的方法]] 我们就提过几种查看泛型函数的代码的操作。比如我们经常使用的print 函数，其实也是个泛型函数：

> 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：

> 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 属性，它就是这个类的实例化对象了：

# 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 系统中，并不存在类对象，类仅仅是通过属性设置的一种“标签”。

同样我们也可以查看某个对象是否是属于某个类：

class(x)
#> [1] "my_class"
inherits(x, "my_class")
#> [1] TRUE
inherits(x, "your_class")
#> [1] FALSE

不仅S3 的类实例创建非常的简单，我们可以直接对class 属性重新赋值来修改对象所属于的类：

# 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：

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 类吧。

##################################################
## 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 会创建一个关于方法名称的向量：

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 包也提供了一些函数去寻找泛型函数对应的类，以及不同类对应的泛型函数：

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方法：

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 的过程：

> sloop::s3_dispatch(bark(dog))
=> bark.animal
 * bark.default

需要注意的是，如果这里的泛型函数会使用其他参数，UseMthod 方法所在的函数需要创建为不定长函数，也就是参数末尾加上...:

bark <- function(x, ...)

7-继承

S3 类提供了继承（inheritance）机制。

class 可以由字符串类型的向量构成。这同样表示，一个S3 对象可以有多个类属性，通过向量表示：

class(ordered("x"))
#> [1] "ordered" "factor"
class(Sys.time())
#> [1] "POSIXct" "POSIXt"

如果这个S3 对象按照顺序的第一个类没有找到对应的方法，R 会依次寻找：

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"

如果是下面这种：

`[.secret` <- function(x, i) {
  new_secret(x[i])
}

为什么会是这样呢：

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系统的子类

我们可以通过不定长参数，为对象的创建引入多个类：

new_secret <- function(x, ..., class = character()) {
  stopifnot(is.double(x))

  structure(
    x,
    ...,
    class = c(class, "secret")
  )
}

接下来可以创建子类的函数以引入新的子类：

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 包以解决这个问题：

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

本文参与腾讯云自媒体同步曝光计划，分享自微信公众号。

原始发表：2022-04-21，如有侵权请联系 cloudcommunity@tencent.com 删除

class

本文分享自北野茶缸子微信公众号，前往查看

如有侵权，请联系 cloudcommunity@tencent.com 删除。

本文参与腾讯云自媒体同步曝光计划，欢迎热爱写作的你一起参与！

登录后参与评论

0 条评论

热度