B01-02 S4系统和RC系统

2017-08-02 20:38:59

S4

S3 vs S4

方面	S3	S4
定义	不需要正式定义，可直接创建对象	必须先正式定义，再创建实例
封装	封装性较差，可以自由修改类对象部件一般采用`$`访问内部部件	封装更严谨，所有部件都可校验合法性需要用`@`访问内部部件(slot)
继承	继承关系松散	继承更严谨，需要用contain正式定义
调度	方法调度(dispatch)时只基于泛型函数的一个参数	方法调度时可基于泛型函数的多个参数

创建类

创建Staff类
- slots定义属性字段类型
- prototype定义字段初始值

setClass("Staff", slots=list(
    name="character", age="numeric", gender="character", level="integer"),
    prototype=list(gender="Male"))

setValidity控制取值合法性

setValidity("Staff", function(object) {
    if (object@gender %in% c("Male", "Female")) TRUE else 
        print("Gender should always be `Male` or `Female`.")
    if (object@age >0) TRUE else print("Age should be positive.")
}) %>% invisible()

实例化

new()函数创建实例

aaron <- new("Staff", name="Aaron", age=30, level=9L)

alice <- new("Staff", name="Alice", gender="F")  ## 未通过校验，返回报错信息

[1] "Gender should always be Male or Female."
Error in if (object@age > 0) TRUE else print("Age should be positive.") : 
  argument is of length zero

alice <- new("Staff", name="Alice", age=29, gender="Female", level=5L)

对象结构

pryr::otype(aaron)

## [1] "S4"

str(aaron)

## Formal class 'Staff' [package ".GlobalEnv"] with 4 slots
##   ..@ name  : chr "Aaron"
##   ..@ age   : num 30
##   ..@ gender: chr "Male"
##   ..@ level : int 9

访问对象部件
- @(相当于$) 或 slot()(相当于[[)

aaron@name

## [1] "Aaron"

slot(alice, "age")

## [1] 29

类继承

创建子类
- contains定义父类

setClass("Employee", slots=list(
    leader="Staff", rate="numeric"), 
    prototype=list(rate=100),
    contains="Staff")

子类实例化

adam <- new("Employee", name="Adam", 
    age=20, level=3L, leader=aaron)

访问部件

adam@leader

## An object of class "Staff"
## Slot "name":
## [1] "Aaron"
## 
## Slot "age":
## [1] 30
## 
## Slot "gender":
## [1] "Male"
## 
## Slot "level":
## [1] 9

定义泛型(generics)

需定义默认方法函数
- 后续定义方法时用到rate, index参数，故泛型中要先作定义
- def中定义函数，参数列表要包含该泛型所调度的方法中所有出现过的参数
- 必须用standardGeneric函数

library(magrittr)
setGeneric("calcBenefit", function(object, rate) {
    standardGeneric("calcBenefit")
}) %>% invisible()

定义方法(method)

津贴计算公式为level*rate
- 如为Employee，提醒其与领导确认金额
- 如为Staff，不指定rate的话，则为Employee类默认rate的1.2倍

setMethod(
    "calcBenefit", signature("Staff"), 
    function(object, rate) {
        o <- object@level * 
            if (missing(rate)) 
                1.2 * new("Employee")@rate 
            else rate
        names(o) <- object@name
        return(o)
}) %>% invisible()

setMethod(
    "calcBenefit", signature("Employee"), 
    function(object, rate) {
        o <- object@level * 
            if (missing(rate)) 
                object@rate 
            else rate
        names(o) <- c(paste(
            object@name, ": please confirm",
            "the amount with your leader", 
            object@leader@name))
        return(o)
}) %>% invisible()

检索

getSlots("Employee")

##      leader        rate        name         age      gender       level 
##     "Staff"   "numeric" "character"   "numeric" "character"   "integer"

hasMethod("calcBenefit", "Staff")

## [1] TRUE

findMethod("calcBenefit", "Staff")

## [[1]]
## <environment: R_GlobalEnv>

getMethod("calcBenefit", "Staff")

## Method Definition:
## 
## function (object, rate) 
## {
##     o <- object@level * if (missing(rate)) 
##         1.2 * new("Employee")@rate
##     else rate
##     names(o) <- object@name
##     return(o)
## }
## 
## Signatures:
##         object 
## target  "Staff"
## defined "Staff"

方法调度

mapply(calcBenefit, object=c(aaron, adam, alice), rate=c(100, 50, 90))

##                                                   Aaron 
##                                                     900 
## Adam : please confirm the amount with your leader Aaron 
##                                                     150 
##                                                   Alice 
##                                                     450

sapply(list(aaron, adam, alice), calcBenefit)

##                                                   Aaron 
##                                                    1080 
## Adam : please confirm the amount with your leader Aaron 
##                                                     300 
##                                                   Alice 
##                                                     600

调度的是哪种方法?

selectMethod("calcBenefit", "Employee")

## Method Definition:
## 
## function (object, rate) 
## {
##     o <- object@level * if (missing(rate)) 
##         object@rate
##     else rate
##     names(o) <- c(paste(object@name, ": please confirm", "the amount with your leader", 
##         object@leader@name))
##     return(o)
## }
## <bytecode: 0x4e79800>
## 
## Signatures:
##         object    
## target  "Employee"
## defined "Employee"

refClass (RC)

引用类(RC)

引用类是R 2.12开始引入的新OO系统，也叫R5
RC与S3、S4完全不同:

#	S3,S4	RC
1	方法的实质是函数	方法的实质是对象
2	遵循R的"修改副本"设计，对象不能修改	对象可以修改，其副本也一同修改
3	OO性质不典型	与其他OO语言(Python, Java, C#)更为接近

RStudio的Winston Chang重写了RC，形成R6系统
RC越来越受高级开发者欢迎，而S4的应用则存在争议

创建RC

setRefClass()命令和setClass()很接近

Car <- setRefClass("Car", fields=list(
    manuf="character", brand="character", status="character"))

创建子类 (contains)

Manual <- setRefClass("Manual", fields=list(auto="logical"), contains="Car")
Auto <- setRefClass("Auto", fields=list(auto="logical"), contains="Car")

实例化

调用内置方法$new()

car1 <- Car$new(manuf="VW", brand="Golf")
car2 <- Manual$new(manuf="VW", brand="Santana", auto=FALSE)

car1

## Reference class object of class "Car"
## Field "manuf":
## [1] "VW"
## Field "brand":
## [1] "Golf"
## Field "status":
## character(0)

car2

## Reference class object of class "Manual"
## Field "manuf":
## [1] "VW"
## Field "brand":
## [1] "Santana"
## Field "status":
## character(0)
## Field "auto":
## [1] FALSE

专用的`$copy()`方法

用赋值方法不能实现副本，而只是链接

car3 <- car2
car2$brand <- "Jetta"
c(car2=car2$brand, car3=car3$brand)

##    car2    car3 
## "Jetta" "Jetta"

必须用$copy()方法

car4 <- car2$copy()
car2$brand <- "Santana"
c(car2=car2$brand, car3=car3$brand, 
  car4=car4$brand)

##      car2      car3      car4 
## "Santana" "Santana"   "Jetta"

定义方法

调用内置方法$methods()

charTime <- function(time=Sys.time()) 
    format(time, "%F %T")
Car$methods(
    init=function() {
        status <<- "running"
        cat(charTime(), "启动！", status)
    },
    end=function() {
        status <<- "stopped"
        cat(charTime(), "停车!", status)
    },
    move=function(speed){
        status <<- "running"
        cat(charTime(), manuf, brand, 
            "时速", speed, "前进...\n", status)
    },
    brake=function(){
        status <<- "stopped"
        cat(charTime(), "刹车", status)
    },
    shiftGear=function(from, to) 
        cat("不知道变速箱的类型", status)
)

用超级赋值号<<-实现对象自我修改
.self代表整个对象, .refClassRef代表类定义
子类Manual和Auto创建在前，不能自动继承Car定义的方法

Manual <- setRefClass("Manual", fields=list(
    auto="logical"), contains="Car")
Auto <- setRefClass("Auto", fields=list(
    auto="logical"), contains="Car")
Manual$methods(
    move=function(speed) 
        cat("\n注意及时换档!\n", callSuper(speed)),
    shiftGear=function(from, to){
        cat(paste(
            charTime(), manuf, brand, "从", from, 
            "档换到", to, "档\n", status))
    }
)
Auto$methods(
    shiftGear=function(from, to) cat("不需手动换档")
)

特殊的方法: $initialize()

$initialize()方法: 对象初始化时运行(?setRefClass)
$callSuper()用于方法内部，调用父类的同名方法

Manual$methods(initialize=function(...) {callSuper(...); auto <<- FALSE})
Auto$methods(initialize=function(...) {callSuper(...); auto <<- TRUE})

car5 <- Manual$new(manuf="GM", brand="Buick")
car6 <- Auto$new(manuf="Tata", brand="RangeRover")

car5  # 自动给auto赋值FALSE

## Reference class object of class "Manual"
## Field "manuf":
## [1] "GM"
## Field "brand":
## [1] "Buick"
## Field "status":
## character(0)
## Field "auto":
## [1] FALSE

car6  # 自动给auto赋值TRUE

## Reference class object of class "Auto"
## Field "manuf":
## [1] "Tata"
## Field "brand":
## [1] "RangeRover"
## Field "status":
## character(0)
## Field "auto":
## [1] TRUE

特殊的方法: $finalize()

$finalize()方法: 删除对象并内存清理(gc())时运行(?setRefClass)

Manual$methods(finalize=function() 
    cat(paste(charTime(), ":", manuf, brand, "手动被摧毁!")))
Auto$methods(finalize=function() 
    cat(paste(charTime(), ":", manuf, brand, "自动被摧毁!")))

rm(car5, car6)
invisible(gc())

## 2017-08-02 20:39:00 : GM Buick 手动被摧毁!

## 2017-08-02 20:39:00 : Tata RangeRover 自动被摧毁!

方法调度(1)

car1$init(); Sys.sleep(1)

## 2017-08-02 20:39:00 启动！ running

cat("\n\n")

car1$move(40); Sys.sleep(2)

## 2017-08-02 20:39:01 VW Golf 时速 40 前进...
##  running

car1$brake(); Sys.sleep(0.5)

## 2017-08-02 20:39:03 刹车 stopped

car1$init(); Sys.sleep(1)

## 2017-08-02 20:39:04 启动！ running

car1$shiftGear(1, 4); Sys.sleep(1)

## 不知道变速箱的类型 running

cat("\n\n")

car1$end()

## 2017-08-02 20:39:06 停车! stopped

方法调度(2)

car2$init(); Sys.sleep(1)

## 2017-08-02 20:39:06 启动！ running

cat("\n\n")

car2$move(40); Sys.sleep(2)

## 2017-08-02 20:39:07 VW Santana 时速 40 前进...
##  running
## 注意及时换档!

car2$brake(); Sys.sleep(0.5)

## 2017-08-02 20:39:09 刹车 stopped

car2$init(); Sys.sleep(1)

## 2017-08-02 20:39:09 启动！ running

car2$shiftGear(1, 4); Sys.sleep(1)

## 2017-08-02 20:39:10 VW Santana 从 1 档换到 4 档
##  running

cat("\n\n")

car2$end()

## 2017-08-02 20:39:11 停车! stopped

R6

R6是Winston Chang (RStudio) 开发的OO系统
RC是基于S4的，R6则重写了RC
R6的用法基本和RC类似，但增加了一些优点:
- 支持公用(public)和私有(private)方法
- 动态绑定(active)和继承(inheritance)
- 速度更快(2-3倍)，占用内存更低

创建R6类

public和private均可包含字段(属性)和函数(方法)
- private定义的字段和函数无法公开访问
self$代表当前对象公开部分，private$代表私有部分

library(R6)
Cat <- R6Class("Cat",
    public=list(
        name=NULL, color=NULL,
        initialize=function(name=NA, color=NA){
            self$name <- name
            self$color <- color
            private$dob <- base::Sys.time()
            self$mew()
        },
        mew=function() print(paste0(self$name, ": mew~")),
        chaseMouse=function() print(paste0(self$name, "'s chasing a mouse!"))
    ),
    private=list(
        dob=NULL
    )
)

实例化

实例化的同时即完成初始化

tom <- Cat$new("Tom", "grayblue")

## [1] "Tom: mew~"

调用公开方法

tom$chaseMouse()

## [1] "Tom's chasing a mouse!"

修改和访问公开属性

tom$color <- "black"; tom$color

## [1] "black"

私有属性/方法无法直接访问

tom$dob

## NULL

增/改属性/方法: $set()

Cat$set("public", "weight", NA)
Cat$set("public", "run", function() print(paste0(self$name, "' running!")))
Cat$set("public", "initialize", function(name=NA, color=NA, weight=NA){
    self$name <- name
    self$color <- color
    self$weight <- weight
    private$dob <- base::Sys.time()
    self$mew()
}, overwrite=TRUE)

定义属性/方法后新增的对象获得新属性/方法

alice <- Cat$new("Alice", "white", 10)

## [1] "Alice: mew~"

alice$run()

## [1] "Alice' running!"

动态绑定

动态绑定用起来像字段，但实际是一个钩子函数

Cat$set("active", "wgt2Kg", function(val) {
    if (missing(val)) return(self$weight * 0.4536)
    else self$weight <- val/0.4536}, overwrite=TRUE)

kitty是8磅的白猫，动态绑定自动换算为千克

kitty <- Cat$new("Kitty", "white", 8)

## [1] "Kitty: mew~"

kitty$wgt2Kg

## [1] 3.6288

如初始不给磅数，动态绑定千克数，可反推出磅数

kitty <- Cat$new("Kitty", "white")

## [1] "Kitty: mew~"

kitty$weight

## [1] NA

kitty$wgt2Kg <- 3.63; kitty$weight

## [1] 8.002646

继承

ExoticShorthair <- R6Class(
    inherit=Cat,
    public=list(
        behave=function() print(paste(self$name, "simply eats and sleeps.")),
        mew=function() print(paste0(self$name, ": (too lazy to mew)"))
    )
)

garfield <- ExoticShorthair$new("Garfield", "orange", 30)

## [1] "Garfield: (too lazy to mew)"

garfield$behave()

## [1] "Garfield simply eats and sleeps."

Thank you!

回到主目录

目录

S4

S3 vs S4

创建类

实例化

类继承

定义泛型(generics)

定义方法(method)

检索

方法调度

调度的是哪种方法?

refClass (RC)

引用类(RC)

创建RC

实例化

专用的$copy()方法

定义方法

特殊的方法: $initialize()

特殊的方法: $finalize()

方法调度(1)

方法调度(2)

R6

R6

创建R6类

实例化

增/改属性/方法: $set()

动态绑定

继承

专用的`$copy()`方法