R-面向对象编程（二）
王诗翔 · 2018-08-18
内容：
- S4
- 引用类（Reference class, RC）
- R6扩展包 ## S4对象系统
在S3之后，R引入一个更正式更严谨的面向对象系统S4。这个系统允许我们使用预定义和继承结构来正式定义类。它也支持多重分派，即根据泛型函数的多个参数的类选择方法。
下面学习如何定义S4类和方法。
定义S4类
与S3不同，S4类要求对类和方法有正式定义。为了定义一个S4类，我们需要调用setClass()并提供一个类成员的表示，该表示称为字段（slot）。
下面我们用S4类重新定义product对象：
setClass("Product",
representation(name = "character",
price = "numeric",
inventory = "integer"))类被定义后，我们可以使用getSlots()从类定义中获取字段：
getSlots("Product")
#> name price inventory
#> "character" "numeric" "integer"现在我们使用new()创建一个新的S4类对象实例，并指定字段的取值：
laptop = new("Product", name = "Laptop-A", price = 299, inventory = 1000)
#> Error in validObject(.Object): invalid class "Product" object: invalid object for slot "inventory" in class "Product": got class "numeric", should be or extend class "integer"你可能会奇怪为什么报错。但仔细查看你会发现inventory必须是整数，而我们输入的1000是数值，它的类不是integer。
laptop = new("Product", name = "Laptop-A", price = 299, inventory = 1000L)
laptop
#> An object of class "Product"
#> Slot "name":
#> [1] "Laptop-A"
#>
#> Slot "price":
#> [1] 299
#>
#> Slot "inventory":
#> [1] 1000现在实例laptop创建好了。
对于S4对象我们仍然可以用typeof()和class()获取信息：
typeof(laptop)
#> [1] "S4"
class(laptop)
#> [1] "Product"
#> attr(,"package")
#> [1] ".GlobalEnv"这次对象的类型是S4，而非列表或其他数据类型，而且它的类是S4类的名字。
我们可以使用检查函数判断是否是S4：
isS4(laptop)
#> [1] TRUE与使用$访问列表或环境不同，我们需要使用@来访问一个S4对象的字段：
laptop@price * laptop@inventory
#> [1] 299000另外我们可以调用slot()函数以字符形式提供字段名来访问一个字段。
slot(laptop, "price")
#> [1] 299我们可以直接修改字段的值，但需要符合类定义：
laptop@price = 299laptop@inventory = 200
#> Error in (function (cl, name, valueClass) : assignment of an object of class "numeric" is not valid for @'inventory' in an object of class "Product"; is(value, "integer") is not TRUE因为类已经预定义好，所以不能给类新增字段：
laptop@value = laptop@price * laptop@inventory
#> Error in (function (cl, name, valueClass) : 'value' is not a slot in class "Product"现在我们另建一个实例，只提供部分字段值：
toy = new("Product", name = "Toys", price = 10)
toy
#> An object of class "Product"
#> Slot "name":
#> [1] "Toys"
#>
#> Slot "price":
#> [1] 10
#>
#> Slot "inventory":
#> integer(0)可以看到inventory被默认赋值空整数向量。如果我们觉得它不是一个合意的默认值，我们可以进行指定一个模板（类的原型）。
setClass("Product",
representation(name = "character",
price = "numeric",
inventory = "integer"),
prototype(name = "Unnamed", price = NA_real_, inventory = 0L))然后我们重建toy：
toy = new("Product", name = "Toys", price = 10)
toy
#> An object of class "Product"
#> Slot "name":
#> [1] "Toys"
#>
#> Slot "price":
#> [1] 10
#>
#> Slot "inventory":
#> [1] 0如果inventory = -1L很显然没有意义，但我们无法在原型以及定义中进行限定，那么该如何做呢？
bottle = new("Product", name = "Bottle", price = 1.5, inventory = -2L)
bottle
#> An object of class "Product"
#> Slot "name":
#> [1] "Bottle"
#>
#> Slot "price":
#> [1] 1.5
#>
#> Slot "inventory":
#> [1] -2下面我们创建一个验证函数，对新建类实例时进行相应的约束条件检验。当输入对象没有错误时，函数返回TRUE，当输入对象有错误时，返回一个字符串向量来描述错误。
这里我们通过检查每个字段的长度和它们是不是缺失值来验证对象的有效性。而且price必须是正数，inventory必须是非负数。
validata_product = function(object){
errors = c(
if( length(object@name) != 1)
"Length of name should be 1"
else if (is.na(object@name))
"name should not be missing value",
if( length(object@price) != 1)
"Length of price should be 1"
else if (is.na(object@price))
"price should not be missing value"
else if (object@price <= 0)
"price must be positive",
if( length(object@inventory) != 1)
"Length of inventory should be 1"
else if (is.na(object@inventory))
"inventory should not be missing value"
else if (object@inventory < 0)
"inventory must be non-negative")
if(length(errors) == 0) TRUE else errors
}上面我们写了一个长函数考虑可能出现的错误值，并进行标注。下面可以用它对bottle进行验证：
validata_product(bottle)
#> [1] "inventory must be non-negative"验证函数返回了预料之中的错误信息。我们可以进一步修改类定义函数，使其没生成一个新的实例时都会自动进行验证。
setClass("Product",
representation(name = "character",
price = "numeric",
inventory = "integer"),
prototype(name = "Unamed",
price = NA_real_, inventory = 0L),
validity = validata_product)下面我们来测试验证：
bottle = new("Product", name = "Bottle")
#> Error in validObject(.Object): invalid class "Product" object: price should not be missing value
bottle = new("Product", name = "Bottle", price = 3, inventory = -2L)
#> Error in validObject(.Object): invalid class "Product" object: inventory must be non-negativeS4继承
S3系统广泛且灵活，而对于S4，我们不能任意添加不在类表示中的字段。
下面举个例子：
bottle = new("Product", name = "Bottle",
price = 3, inventory = 100L, volume = 15)
#> Error in initialize(value, ...): invalid name for slot of class "Product": volume添加只能通过继承来完成。我们创建一个新类，它包含（或继承自）原始类。在这个例子中，我们定义一个Container类，它继承自Product类，而且有一个新的名为volume的数值字段。
setClass("Container",
representation(volume = "numeric"),
contains = "Product")查看现在已有的字段：
getSlots("Container")
#> volume name price inventory
#> "numeric" "character" "numeric" "integer"现在构建一个实例：
bottle = new("Container", name = "Bottle",
price = 3, inventory = 100L, volume = 15)
bottle
#> An object of class "Container"
#> Slot "volume":
#> [1] 15
#>
#> Slot "name":
#> [1] "Bottle"
#>
#> Slot "price":
#> [1] 3
#>
#> Slot "inventory":
#> [1] 100注意Product类的验证函数适用于Container类：
bottle = new("Container", name = "Bottle",
price = 3, inventory = -10L, volume = 15)
#> Error in validObject(.Object): invalid class "Container" object: inventory must be non-negative但这个验证函数对新增的字段没用：
bottle = new("Container", name = "Bottle",
price = 3, inventory = 10L, volume = -2)因此我们可以为Container类定义验证函数：
validate_container = function(object){
errors = c(
if (length(object@volume) != 1)
"Length of volume must be 1",
if (object@volume <= 0)
"volume must be positive"
)
if (length(errors) == 0) TRUE else errors
}现在重新定义Container类：
setClass("Container",
representation(volume = "numeric"),
contains = "Product",
validity = validate_container)记得我们不需要在validate_container()中调用validate_product()，因为它们被被依次调用来确保所有位于继承链上的类都被适当的检查。
定义S4泛型函数
我们用一个关于形状的例子进行说明。首先Shape是处于根节点的类，Polygon和Circle都继承自Shape，而Triangle和Rectangle继承自Polygon。
setClass("Shape")
setClass("Polygon",
representation(sides = "integer"),
contains = "Shape")
setClass("Triangle",
representation(a = "numeric", b = "numeric", c = "numeric"),
prototype(a = 1, b = 1, c = 1, sides = 3L),
contains = "Polygon")
setClass("Rectangle",
representation(a = "numeric", b = "numeric"),
prototype(a = 1, b = 1, sides = 4L),
contains = "Polygon")
setClass("Circle",
representation(r = "numeric"),
prototype(r = 1, sides = Inf),
contains = "Shape")我们接着构建一个泛型函数计算一个Shape对象的面积。为此，我们需要调用setGeneric()创建一个新的泛型函数：area()，并为area()提供一个调用standardGeneric("area")的函数使这个新的泛型函数可以用于S4方法分派。参数valueClass是用来确保每种方法的返回值必须是numeric类：
setGeneric("area", function(object) {
standardGeneric("area")
}, valueClass = "numeric")
#> [1] "area"一旦构建了泛型函数，我们可以为不同种类的形状实现不同的方法。对于Triangle，给定三角形的3个边长，然后用公式计算面积。
setMethod("area", signature("Triangle"), function(object){
a = object@a
b = object@b
c = object@c
s = (a + b + c) / 2
sqrt(s * (s - a) * (s - b) * (s - c))
})Rectangle与Circle的面积公式就很简单了：
setMethod("area", signature("Rectangle"), function(object){
object@a * object@b
})
setMethod("area", signature("Circle"), function(object){
pi * object@r ^2
})现在我们创建一个Triangle类的对象实例，查看area()是否会分派正确的方法，返回正确的答案：
triangle = new("Triangle", a = 3, b = 4, c = 5)
area(triangle)
#> [1] 6再创建一个Circle对象实例，看方法分配是否正常：
circle = new("Circle", r = 3)
area(circle)
#> [1] 28.3泛型函数area()工作方式与S3的泛型函数类似，都是根据输入对象的类执行方法分派。
多重分派
S4泛型函数可以根据多个参数执行方法分派。
我们另外定义一个S4类，具有数值height类表示的Object类。Cylinder和Cone都继承Object。然后我们使用多重分派计算具有特定形状的特定几何物的体积：
setClass("Object", representation(height = "numeric"))
setClass("Cylinder", contains = "Object")
setClass("Cone", contains = "Object")现在我们定义一个名为volume的泛型函数，用来计算对象的体积，其中这个对象由底面形状和对象的几何体形状描述：
setGeneric("volume",
function(shape, object) standardGeneric("volume"))
#> [1] "volume"接下来的代码实现两种几何体体积的计算方法：一种是长方体，另一种是四棱锥：
setMethod("volume", signature("Rectangle", "Cylinder"),
function(shape, object) {
shape@a * shape@b * object@height
})setMethod("volume", signature("Rectangle", "Cone"),
function(shape, object){
shape@a * shape@b * object@height /3
})计算体积需要两个参数：
rectangle = new("Rectangle", a = 2, b = 3)
cylinder = new("Cylinder", height = 3)
volume(rectangle, cylinder)
#> [1] 18更进一步，我们通过实现方法*来简化：
setMethod("*", signature("Shape", "Object"),
function(e1, e2) {
volume(e1, e2)
})现在我们可以更简单地进行计算：
rectangle * cylinder
#> [1] 18引用类RC
R还有一种具有引用语义的类系统，它更像其他面向对象编程语言中的类系统。
不像S4类系统使用new()创建一个对象实例，setRefClass()会返回一个对象实例生成器。
例如我们定义一个Vehicle类，它有两个字段：一个数值位置和一个数值距离。
Vehicle = setRefClass("Vehicle",
fields = list(position = "numeric", distance = "numeric"))创建新对象实例：
car = Vehicle$new(position =0, distance = 0)RC的字段通过$访问：
car$position
#> [1] 0下面定义move()函数，它修改相对位置，并累积距离，即相对地修改position，并将所有的移动累计到参数distance上：
move = function(vehicle, movement) {
vehicle$position = vehicle$position + movement
vehicle$distance = vehicle$distance + abs(movement)
}现在调用move()：我们发现对象实例car确实被修改了，而不是复制：
move(car, 10)
car
#> Reference class object of class "Vehicle"
#> Field "position":
#> [1] 10
#> Field "distance":
#> [1] 10引用类本身是一个类系统，并且更像一般的面向系统，所以我们最好定义类的方法以便于更好地使用：
Vehicle = setRefClass("Vehicle",
fields = list(position = "numeric", distance = "numeric"),
methods = list(move = function(x) {
stopifnot(is.numeric(x))
position <<- position + x
distance <<- distance + abs(x)
}))S3、S4系统中，方法存储在环境中，而RC本身包含它的方法，因此可以直接调用一个对象实例中的方法。但在方法中修改字段的值，要用<<-而不是<-。
下面检验对象实例中方法是否有效：
bus = Vehicle(position = 0, distance = 0)
bus$move(5)
bus
#> Reference class object of class "Vehicle"
#> Field "position":
#> [1] 5
#> Field "distance":
#> [1] 5R6
R6是加强版的RC，它是一个扩展包，能够实现支持公共与私有字段与方法的更有效的引用类，还有一些其他的强大功能。
运行安装该包：
install.packages("R6")R6类允许我们定义类，其行为特征更类似于流行的面向对象编程语言。我们使用下面代码定义Vehicle类，它既有面向用户的公共字段和方法，也有供内部使用的私有字段和方法：
library(R6)
Vehicle = R6Class("Vehicle",
public = list(
name = NA,
model = NA,
initialize = function(name, model) {
if(!missing(name)) self$name = name
if(!missing(model)) self$model = model
},
move = function(movement){
private$start()
private$position = private$position + movement
private$stop()
},
get_position = function(){
private$position
}
),
private = list(
position = 0,
speed = 0,
start = function(){
cat(self$name, "is starting\n")
private$speed = 50
},
stop = function(){
cat(self$name, "is stopping\n")
private$speed - 0
}
))从用户端，我们只能访问公共字段和方法。只有类方法可以访问私有字段和方法。这里我们将position放在私有部分以避免用户从外部修改它。
car = Vehicle$new(name = "Car", model = "A")
car
#> <Vehicle>
#> Public:
#> clone: function (deep = FALSE)
#> get_position: function ()
#> initialize: function (name, model)
#> model: A
#> move: function (movement)
#> name: Car
#> Private:
#> position: 0
#> speed: 0
#> start: function ()
#> stop: function ()调用方法：
car$move(10)
#> Car is starting
#> Car is stopping
#> [1] 50
car$get_position()
#> [1] 10为演示R6类的继承关系，我们定义叫MeteredVehicle的新类，它能够记录移动的历史距离之和。为此，我们新增一个私有字段distance，然后重写公共字段move，使其优先调用super$move()将交通工具移动到正确位置，并累计移动的绝对距离：
MeteredVehicle = R6Class("MeteredVehicle",
inherit = Vehicle,
public = list(
move = function(movement) {
super$move(movement)
private$distance <<- private$distance + abs(movement)
},
get_distance= function(){
private$distance
}),
private = list(
distance = 0
))现在我们做一些试验，创建bus：
bus = MeteredVehicle$new(name = "Bus", model = "B")
bus
#> <MeteredVehicle>
#> Inherits from: <Vehicle>
#> Public:
#> clone: function (deep = FALSE)
#> get_distance: function ()
#> get_position: function ()
#> initialize: function (name, model)
#> model: B
#> move: function (movement)
#> name: Bus
#> Private:
#> distance: 0
#> position: 0
#> speed: 0
#> start: function ()
#> stop: function ()让bus向前移动10单位，相应位置改变，距离累计：
bus$move(10)
#> Bus is starting
#> Bus is stopping
bus$get_position()
#> [1] 10
bus$get_distance()
#> [1] 10再让bus后移5单位：
bus$move(-5)
#> Bus is starting
#> Bus is stopping
bus$get_position()
#> [1] 5
bus$get_distance()
#> [1] 15关于R6更详细的介绍，请阅读和参考官方文档。
总结一下，R里面当前4个类系统我们主要关注S3、S4和R6。S3、4如果要精通R是必须掌握的，如果有用到类似其他语言或者参考其他语言实现功能，可以用到R6。