R面向对象编程S4

Posted at — May 5, 2012

1. 一些S3的铺垫

在博文“Linux安装R语言包”描述了如何查看一个函数的源代码，其中涉及了例如methods()函数，用来查看一个S3泛函（S3 generic）的方法。在pryr包中，提供了更加便捷的查看方法。

library('pryr')

## object is base type, S3, S4 or RC
otype(obj)

## function is genetic or method
ftype(method)

2. 类

2.1 建立新类

setClass(Class, representation, prototype, contains=character(),
         validity, access, where, version, sealed, package,
         S3methods = FALSE, slots)

Class：类名。

slots：带名字的列表或者字符向量，名字表示slot，内容表示slot对应的类名。

contains：父类名，表示继承关系。

prototype：带名setGroupGeneric字的列表或prototype()，设定默认值。不建议添加，如果不设定，会自动指定一个符合类型的空值。设定时，要结合validity定义，因为默认值不会被检查，因为即使不符合validity定义，也可以通过validObject()检查。

validity：函数，检查创建对象是否符合该类要求。建议添加，也可以使用setValidity()后期添加。

where：环境（少用）。

sealed：是否封闭，如果设定为TRUE，其他setClass()不能调用该类。

package：包名（少用）

S3methods/representation/access/version：在3.0.0版本后不建议使用。

例子：

## new class
setClass(Class = 'trick',
         slots = c(id = 'character', time = 'matrix'),
         validity = function(object) {
           if (length(object@id) != nrow(object@time)) {
             warns <- paste('length of id is', length(object@id), 'is not equal to row number of time', nrow(object@time))
             return(warns)
           } else {
             return(TRUE)
           }},
         prototype = list(id = character(), time = matrix(0, 0, 0)))

setClass(Class = 'trickNum',
         slots = c(number = 'numeric'),
         contains = 'trick')

setClass(Class = 'trickMult',
         slots = c(trick1 = 'trick', trick2 = 'trick'))

## from setClass() help document, extend from built-in data type
setClass("numWithId", 
         slots = c(id = "character"),
         contains = "numeric")

numWI1 <- new('numWithId', 1:10, id = letters[1:10])
## retrieve data of numWI1
numWI1@.Data

## without slots
numNoSlot <- setClass("num", contains = "numeric")

## simplest class
setClass(Class = 'simpleClass')

使用setOldClass()转换S3类型对象，使用getClass('oldClass')查询oldClass。

structure(list(), class = 'TestS3Class')

setOldClass('TestS3Class')

2.2 创建、查看和删除对象

创建对象：

new(Class, ...)

Class：类名。

…：各个slot赋值。如果没有赋值，则使用初始化值。

在使用new()建立新的对象之前，会经历“初始化”。初始化可以对新建对象做一些事先固定的操作，比如给某一个slot添加名字等。这需要使用setMethod()重新定义initialize()泛函，考虑使用callNextMethod()，以保证子类也能够继承初始化，同时需要考虑“空对象”问题。由于callNextMethod()是向父类搜索，在有很多继承关系时，搜索结果会变得难以预测，因此尽量减少使用。

## first initialize can not be correctly inherited
setMethod(f = 'initialize',
          signature = 'trick',
          definition = function(.Object, id = character(), time = matrix(0, 0, 0)) {

            colNum <- ncol(time)
            if (colNum > 0) {
              colnames(time) <- paste0(letters[1:colNum], 1:colNum)
            } else {}

            .Object@id <- id
            .Object@time <- time

            return(.Object)
          })
t1 <- new('trick', id = letters[1:3], time = matrix(1:9, ncol = 3))
try(new('trickNum', id = letters[1:3], time = matrix(1:9, ncol = 3), number = 5:6))

## second initialize can not be correctly inherited
setMethod(f = 'initialize',
          signature = 'trick',
          definition = function(.Object, ...) {

            colNum <- ncol(.Object@time)
            if (colNum > 0) {
              colnames(.Object@time) <- paste0(letters[1:colNum], 1:colNum)
            } else {}

            return(.Object)
          })
try(new('trick', id = letters[1:3], time = matrix(1:9, ncol = 3)))
## not as expected, all slots are empty
try(new('trickNum', id = letters[1:3], time = matrix(1:9, ncol = 3), number = 5:6))

## third initialize using callNextMethod() works well
setMethod(f = 'initialize',
          signature = 'trick',
          definition = function(.Object, ...) {

            .Object <- callNextMethod()

            colNum <- ncol(.Object@time)
            if (colNum > 0) {
              colnames(.Object@time) <- paste0(letters[1:colNum], 1:colNum)
            } else {}

            return(.Object)
          })
t1 <- new('trick', id = letters[1:3], time = matrix(1:9, ncol = 3))
tn1 <- new('trickNum', id = letters[1:3], time = matrix(1:9, ncol = 3), number = 5:6)

查看对象和类：

getClass('className')：查询一个类的情况，也包括该类的继承情况。返回结果的“Subclasses”表示含有的子类，“Extends”表示父类是什么。
getSlots('className')：查询某一个class的slots。
slotNames(objName)：查询一个对象的slots名称。
@和slot(objName, 'slotName')：查询一个对象的slot的值。也可以使用objName@slotName <- somVal和slot(objName, 'slotName') <- someVal赋值，只会检查slot对应的类型，不会检查validity设定。一定不要执行slot(objName, 'slotName', check = FALSE) <- someVal，否则连类型都不检查。@定义在base包，slot()在methods包。
.hasSlot(objName, 'slotName')：查询一个对象是否有某个slot。
is(myObj, 'myClass')：判断某个对象是否属于类，会向上查找父类，如果对象属于父类，也返回TRUE。is(MyOb)，返回某个对象的类和所有父类。

删除对象：

removeClass('className')：删除类，但是会保留这个类的方法和子类。

3. 方法

3.1 建立方法

方法和泛函的关系非常密切，某一个方法必须建立在一个特定泛函下。因此，建立方法时，首先确定该方法是否存在泛函：

如果不存在，首先使用setGeneric()建立泛函；
如果存在，使用setMethod()建立具体方法。

setGeneric(name, def= , group=list(), valueClass=character(),
           where= , package= , signature= , useAsDefault= ,
           genericFunction= , simpleInheritanceOnly = )

name：字符串，泛函名称。
def：函数，定义新的泛函，比如结合standardGeneric()函数。参数默认值在这里定义，后面的具体方法中参数默认值无效。
group：字符串，指示该泛函所属的泛函组。
valueClass：字符向量，一个或多个类，强制规定该泛函返回类型必须符合或包括类。
where：环境（少用）。
package：包名，一般自动识别。
signature：名字向量。
useAsDefault：推翻默认设置。
genericFunction：不建议使用。
simpleInheritanceOnly：逻辑值。

setMethod(f, signature=character(), definition,
          where = topenv(parent.frame()),
          valueClass = NULL, sealed = FALSE)

f：字符串，泛函名称。
signature：字符向量，指定definition中函数变量对应的类名。两个特殊类"missing"和"ANY"，分别表示对应的变量“不能出现在方法调用中”和“可以是任何类”。如果一个变量没有被指定，则默认为"ANY"。
definition：函数，定义方法。在创建函数时，特别是扩展已有泛函，f(para)中的变量与原始泛函的数量和名称一致。比如在print(x, ...)，变量是x和...。而在show(object)中，变量是x。可以使用args()查看泛函的参数。同时，函数中可以含有未被定义的变量...，后面setMethod()方法可以添加泛函声明变量之外的变量；如果没有...，后续方法只能操作泛函申明的变量。
where：环境（少用）。
valueClass：废弃变量。
sealed：是否封闭，如果设定为TRUE，其他setMethod()不能重新定义该方法，但可以被删除和重新指定。

对于一个对象，可以用一个泛函处理多个不同情况，比如不同的类（包括"missing"和"ANY"）、父类/子类。同时，子类会自动继承父类的方法。但是，如果子类定义了与父类名称相同的方法，则父类方法不再起作用。需要强制“回溯”父类方法，使用callNextMethod()。

## plot() is initially not a S4 generic function, 
## but was automatically created.
## it is equalt to setGeneric('plot')
setMethod(f = 'plot',
          signature = c(x = 'trick'),
          definition = function(x, y, ...) {
            matplot(x = slot(x, 'time'), pch = slot(x, 'id'))
          })

## set new generic function
setGeneric(name = 'Add', def = function(x, y, ...){standardGeneric('Add')})

## test "missing" class
setMethod(f = 'Add',
          signature = c(x = 'trick', y = 'missing'),
          definition = function(x, y, ...) {
            slot(x, 'time') <- slot(x, 'time') + 1
            return(x)
          })

## another function
setMethod(f = 'Add',
          signature = c(x = 'trick', y = 'numeric'),
          definition = function(x, y, ...) {
            slot(x, 'time') <- slot(x, 'time') + y
            return(x)
          })

## with one more parameter "isabs"
## which is not defined in the generic function
## thank for "..."
setMethod(f = 'Add',
          signature = c(x = 'trick', y = 'numeric'),
          definition = function(x, y, isabs = FALSE, ...) {
            slot(x, 'time') <- slot(x, 'time') + ifelse(isabs, abs(y), y)
            return(x)
          })
## getMethod
getMethod('Add', c('trick', 'numeric'))

Add(t1)
Add(t1, -1)
Add(t1, -1, isabs = TRUE)
Add(tn1, -1, isabs = TRUE)

## test callNextMethod()
setMethod(f = 'Add',
          signature = c(x = 'trickNum', y = 'numeric'),
          definition = function(x, y, callNext = FALSE, ...) {
            if (callNext) {
              x <- callNextMethod()
            } else {}
            slot(x, 'number') <- slot(x, 'number') + y
            return(x)
          })
Add(tn1, -1)
Add(tn1, -1, callNext = TRUE, isabs = TRUE)

3.2 获取和修改对象

重置[、[[和$获取对象。重置[<-、[[<-和$<-修改对象（改变原始对象），建议使用validObject()检查修改后的对象。

## set "[" and "[<-"
setMethod(f = "[",
          signature = c(x = 'trickNum'),
          definition = function(x, i, j, ..., drop) {
            return(slot(x, i))
          })

setMethod(f = "[<-",
          signature = 'trickNum',
          definition = function(x, i, j, ..., value) {
            slot(x, i) <- value
            validObject(x)
            return(x)
          })

tn1['time']
try(tn1['joke'])
tn1['id'] <- LETTERS[1:3]
try(tn1['id'] <- LETTERS[1:4])

## define "numData" and "numData<-"
setGeneric(name = 'numData', def = function(x, ...){standardGeneric('numData')})
setGeneric(name = 'numData<-', def = function(x, value, ...){standardGeneric('numData<-')})

setMethod(f = "numData",
          signature = 'numWithId',
          definition = function(x, ...) {
            return(x@.Data)
          })

setMethod(f = "numData<-",
          signature = c(x = 'numWithId', value = 'numeric'),
          definition = function(x, value, ...) {
            x@.Data = value
            validObject(x)
            return(x)
          })

numData(numWI1)
numData(numWI1) <- 10:1

3.3 泛函组

S4允许将一类方法定义为“泛函组（group generic functions）”。已经定义的泛函组，比如ops，通过?S4groupGeneric查看。使用setGroupGeneric()定义新的泛函组，使用callGeneric()调用泛函组，比如：

setMethod('Ops',
          signature(e1='trick', e2='trick'),
          function(e1, e2) {
            e1@time <- callGeneric(slot(e1, 'time'), slot(e2, 'time'))
            validObject(e1)
            return(e1)
          })

t1 <- new('trick', id = letters[1:3], time = matrix(1:9, ncol = 3))
t2 <- new('trick', id = letters[1:3], time = matrix(9:1, ncol = 3))
t1 + t2

3.4 查看和删除方法

查看方法：

methods('fun')：查看某个函数的具体信息，根据结果判断是否为S4。
getGeneric('genfun')：查看某个泛函的定义。
findMethods('genfun')：查看某个泛函的代码。
showMethods('genfun', classes = 'myClass')：某个泛函的总结信息，可以指定类。也可以只声明classes，从而查看某些类的全部方法。
getMethod('myMethod', 'myClass')和selectMethod('genfun', 'myClass')：查看某个类的某个方法的具体代码，前者只查找制定的类，后者会向父类查找直到找到为止。
existsMethod('myMethod', 'myClass')和hasMethod('genfun', 'myClass')：判断某个类是否有某个方法，前者只查找制定的类，后者会向父类查找直到找到为止。

删除方法：

removeGeneric('genfun')：删除泛函。
removeMethods('myMethod')：删除方法。

4. 确认检查

创建对象时：

自动检查每个slot赋值类型是否正确，这种检查会一直被子类和slot含有该类的类（简称“slot含有类”）继承。
如果设定了validity，这种检查将一直被子类继承，但是slot含有类不会去检查slot赋值是否正确。对于这种情况，将validObject(object, test = FALSE, complete = FALSE)函数的complete参数设定为TRUE，可以检查出问题。
如果自定义了initialize()方法，建议使用callNextMethod()的形式，这样会进行setClass()的validity检查。

修改slot时：

使用slot()和@，只会检查slot类型是否正确，不会检查validity设定。不建议用户直接使用@。

推荐在setClass()建立类时，同时设定好validity，而不是使用setValidity(Class, method, where = topenv(parent.frame()))后续设定。

## correct "trick" obj
t1 <- new('trick', id = letters[1:3], time = matrix(1:9, ncol = 3))
## not validated "trick" obj
t2 <- t1
t2@id <- letters[1:4]
## return FALSE
validObject(t2)
## error
try(new('trick', id = letters[1:3], time = 1:4))
try(new('trick', id = letters[1:3], time = matrix(1:8, ncol = 4)))

## correct "trickNum" obj
tn1 <- new('trickNum', id = letters[1:3], time = matrix(1:9, ncol = 3), number = 5:6)
## error because can not pass "trick" validate
try(new('trickNum', id = letters[1:3], time = 1:4, number = 5:6))
try(new('trickNum', id = letters[1:3], time = matrix(1:8, ncol = 4), number = 5:6))

## error
try(new('trickMult', trick1 = new('trick', id = letters[1:3], time = 1:4)))
try(new('trickMult', trick1 = new('trick', id = letters[1:3], time = matrix(1:8, ncol = 4))))

tm1 <- new('trickMult', trick1 = t2)
## return TRUE
validObject(tm1)
## return FALSE
validObject(tm1, complete = TRUE)

5. 继承

5.1 类转换

setClass()的contains参数规定了继承的父类，很直接的继承关系（simple inheritance）。使用as()（不改变原始对象的值）和as() <- value进行转换。

as(myObj, 'myClass')分为三种情况：

myObj是子类对象，myClass是父类，返回只含有父类的slots（“剪枝”）。
myObj是父类对象，myClass是子类，返回多余的子类slots填充默认值。
myObj是myClass的一个对象，没有变化。

as(myObj, 'myClass') <- value有四种特殊情况：

as(objSon1, 'classFather') <- objSon2行为等同于objSon1 <- objSon2。
as(objSon, 'classFather') <- objFather父类slots的值“遗传”给子类，返回classSon类的对象。
as(objFather1, 'classSon') <- objFather2报错。
as(objFather, 'classSon') <- objSon报错。

使用setIs()显示继承（explicit inheritance），尽量少用或使用setAs()代替。但是，setIs()使得class1变成class2的子类，class2的一些方法可能失效。因为，两个类的slots可能有很大的不同。因此，使用as()将class1转换成class2，再使class2的方法。

setIs(class1, class2, test=NULL, coerce=NULL, replace=NULL,
      by = character(), where = topenv(parent.frame()), classDef =,
      extensionObject = NULL, doComplete = TRUE)

class1：字符串，需要转换的类。
class2：字符串，目标类。
test：转化检查，不推荐。
coerce：函数，一个参数，例如from。目的是从from中提取和处理一些slots，之后用这些处理后的slot建立一个class2的对象并返回。coerce对应的函数就是将class1转化成class2，因此要返回一个class2的对象。这也意味着class1将成为class2的一个子类。使用showMethods(“coerce”)查询内建的coerce函数。
replace：函数，目的是实现类似as(obj,"class2") <- value。变量可以设为两个，例如from和value，最后返回处理好的from。
by：不建议使用。
where：设定环境。
classDef：不建议使用。
useAsDefault：推翻默认设置。
extensionObject/doComplete：不建议使用。

setAs(from, to, def, replace, where = topenv(parent.frame()))

from：字符串，需要转换的类。
to：字符串，目标类。
def：函数，参数from（from或to），目的是将from转化成to。
replace：函数，参数from和value，目的是实现类似as(obj,"to") <- value。
where：设定环境。

t2 <- new('trick', id = LETTERS[3:1], time = matrix(9:1, ncol = 3))
tn2 <- new('trickNum', id = LETTERS[3:1], time = matrix(10:2, ncol = 3), number = 5:6)

as(tn2, 'trick')
as(t2, 'trickNum')

as(tn2, 'trick') <- tn1
as(tn2, 'trick') <- t2
try(as(t2, 'trickNum') <- tn1)
try(as(t2, 'trickNum') <- t1)

setClass(Class = 'trickNumMat',
         slots = c(number = 'matrix',
                   id = 'character',
                   time = 'matrix'))
setIs(class1 = 'trickNum',
      class2 = 'trickNumMat',
      coerce = function(from) {
        toObj <- new('trickNumMat',
                     number = as.matrix(from@number),
                     id = from@id,
                     time = from@time)
        return(toObj)
      },
      replace = function(from, value) {
        from@number = as.numeric(value@number)
        from@id = value@id
        from@time = value@time

        return(from)
      })
as(tn1, 'trickNumMat')
tnm1 <- new('trickNumMat',
            number = matrix(rnorm(1:9), nrow = 3),
            id = LETTERS[1:3],
            time = matrix(1:9, ncol = 3))
as(tn1, 'trickNumMat') <- tnm1

5.2 虚类

S4允许创建一个称为“虚类”的类。对于虚类，可以构建方法，可以创建子类，但是不能创造一个属于虚类的对象。虚类是为了解决“交集”的问题，即创建的多个新类中可能含有共同的slots。因此，将这些共同的slots处理成虚类，之后建立属于虚类的方法。这样，虚类下属的子类就能顺利继承。创建方法：第一种，setClass()函数的变量contains中加入VIRTUAL；第二种，setClass()函数只含有变量Class。

setClass(Class = 'trickVirtual',
         contains = c(id = 'character', 'VIRTUAL'))
setClass(Class = 'trickA',
         contains = 'trickVirtual',
         slots = c(number = 'numeric'))
setClass(Class = 'trickB',
         contains = 'trickVirtual',
         slots = c(log = 'logical'))
getClass('trickVirtual')

setClass(Class = 'testVirtual')
getClass('testVirtual')

5.3 类群

类群是为了解决“并集”的问题，即把功能相似的类合成一个“类群”，每次使用时只用其中的一个。因此，创建的“类群”是一个父类。使用isClassUnion(Class)检验某个类是否为类群，使用setClassUnion(name, members, where)创建类群。在使用类群时，默认使用的是第一个定义的类。每一个类群是一个虚类。

setClassUnion(name, members, where)

name：字符串，类群名。
members：字符向量，一个或多个已定义的类。可以后续使用setIs()向类群中添加已定义的类。
where：设定环境。

setClassUnion("trickUnion", c("logical", "numeric"))
setClass("trickUA", contains = 'trickUnion', slots = c(id = 'numeric'))
new('trickUA', 1:10, id = 1)
getClass('trickUnion')

6. 建立对象注意事项

把所有对象写入一个文件AllClass.R，所有泛函写入AllGeneric.R。
setClass()建立一个类，同时添加validity验证。
自定义initialize()（可选，建议使用默认设置）。
自定义构造函数，比如类似类名，MyClass <- function(slot1, ...){new('myClass', slot1 = slot1, ...)}（可选，建议把initialize()内容放入）。
自定义show()，用于合理展示类。例如，一个大的矩阵，可以只展示一部分。而print()用于展示类的全部信息。
修改slot后，对返回的对象进行validObject()检查。

参考资料

A (Not So) Short Introduction to S4：详细的S4介绍。
Advance R – S4
S4 System Development in Bioconductor
R Programming for Bioinformatics

更新记录

2017年9月7日

Yulong Niu

个人博客