Blog Archives

R语言基于R6的面向对象编程

R的极客理想系列文章,涵盖了R的思想,使用,工具,创新等的一系列要点,以我个人的学习和体验去诠释R的强大。

R语言作为统计学一门语言,一直在小众领域闪耀着光芒。直到大数据的爆发,R语言变成了一门炙手可热的数据分析的利器。随着越来越多的工程背景的人的加入,R语言的社区在迅速扩大成长。现在已不仅仅是统计领域,教育,银行,电商,互联网….都在使用R语言。

要成为有理想的极客,我们不能停留在语法上,要掌握牢固的数学,概率,统计知识,同时还要有创新精神,把R语言发挥到各个领域。让我们一起动起来吧,开始R的极客理想。

关于作者:

  • 张丹(Conan), 程序员Java,R,PHP,Javascript
  • weibo:@Conan_Z
  • blog: http://blog.fens.me
  • email: bsspirit@gmail.com

转载请注明出处:
http://blog.fens.me/r-class-r6/

r-class-r6

前言

R6是什么?听说过S3、S4和RC(R5)的面向对象类型 ,R6难道是一种新的类型吗?

其实,我也是在无意中发现R6的。R6是R语言的一个面向对象的R包,R6类型非常接近于RC类型(Reference classes),但比RC类型更轻,由于R6不依赖于S4的对象系统,所以用R6的构建面向对象系统会更加有效率。

目录

  1. 初识R6
  2. 创建R6类和实例化对象
  3. R6类的主动绑定
  4. R6类的继承关系
  5. R6类的对象的静态属性
  6. R6类的可移植类型
  7. R6类的动态绑定
  8. R6类的打印函数
  9. 实例化对象的存储
  10. R6面向对象系统的案例

1. 初识R6

R6是一个单独的R包,与我们熟悉的原生的面向对象系统类型S3,S4RC类型不一样。在R语言的面向对象系统中,R6类型与RC类型是比较相似的,但R6并不基于S4的对象系统,因此我们在用R6类型开发R包的时候,不用依赖于methods包,而用RC类型开发R包的时候则必须设置methods包的依赖,在发布gridgame游戏包 文章中,就会出现RC依赖于methods包的使用情况。

R6类型比RC类型更符合其他编程对于面向对象的设置,支持类的公有成员和私有成员,支持函数的主动绑定,并支持跨包的继承关系。由于RC类型的面向对象系统设计并不彻底,所以才会有R6这样的包出现。下面就让我们体会一下,基于R6面向对象系统编程吧。

2. 创建R6类和实例化对象

本文的系统环境

  • Win7 64bit
  • R: 3.1.1 x86_64-w64-mingw32/x64 (64-bit)

我们先安装R6包,同时为了方便我们检查对象的类型,引入pryr包作为辅助工具。关于pryr包的介绍,请参看撬动R内核的高级工具包pryr一文。


~ R                         # 启动R程序
> install.packages("R6")    # 安装R6包
> library(R6)               # 加载R6包
> library(pryr)             # 加载pryr包

注:R6同时支持Win7环境和Linux环境

2.1 如何创建R6类?

R6对象系统是以类为基本类型, 有专门的类的定义函数 R6Class() 和 实例化对象的生成方法,下面我们用R6对象系统创建一个类。

先查看R6的类创建函数R6Class()函数的定义。


> R6Class
function (classname = NULL, public = list(), private = NULL,
    active = NULL, inherit = NULL, lock = TRUE, class = TRUE,
    portable = TRUE, parent_env = parent.frame())

参数列表:

  • classname 定义类名。
  • public 定义公有成员,包括公有方法和属性。
  • private 定义私有成员,包括私有方法和属性。
  • active 主动绑定的函数列表。
  • inherit 定义父类,继承关系。
  • lock 是否上锁,如果上锁则用于类变量存储的环境空间被锁定,不能修改。
  • class 是否把属性封装成对象,默认是封装,如果选择不封装,类中属性存存在一个环境空间中。
  • portable 是否为可移植类型,默认是可移植型类,类中成员访问需要用调用self和private对象。
  • parent_env 定义对象的父环境空间。

从R6Class()函数的定义来看,参数比RC类定义函数的setRefClass()函数有更多的面对对象特征。

2.2 创建R6的类和实例化对象

我们先创建一个最简单的R6的类,只包括一个公有方法。


> Person <- R6Class("Person",    # 定义一个R6类
+  public=list(
+    hello = function(){         # 定义公有方法hello
+      print(paste("Hello"))
+    }
+  )
+)

> Person                   # 查看Person的定义
<Person> object generator
  Public:
    hello: function
  Parent env: 
  Lock: TRUE
  Portable: TRUE

> class(Person)             # 检查Person的类型
[1] "R6ClassGenerator"

接下来,实例化Person对象,使用$new()函数完成。


> u1<-Person$new()   # 实例化一个Person对象u1
> u1                 #查看u1对象
<Person>
  Public:
    hello: function
> class(u1)           # 检查u1的类型
[1] "Person" "R6"

通过pryr包的otype检查Person类的类型和u1对象的实例化类型。


> otype(Person)   # 查看Person类型
[1] "S3"
> otype(u1)       # 查看u1类型
[1] "S3"

完全没有想到的结果,Person和u1都是S3类型的。如果R6是基于S3系统构建的,那么其实就可以解释R6类型与RC类型的不同,并且R6在传值和继承上会更有效率。

2.3 公有成员和私有成员

类的成员,包括属性和方法2部分。R6类定义中,可以分开设置公有成员和私有成员。我们设置类的公有成员,修改Person类的定义,在public参数中增加公有属性name,并通过hello()方法打印name的属性值,让这个R6的类更像是Java语言的JavaBean。在类中访问公有成员时,需要使用self对象进行调用。


> Person <- R6Class("Person",
+  public=list(
+    name=NA,                           # 公有属性
+    initialize = function(name){       # 构建函数方法
+      self$name <- name
+    },
+    hello = function(){                # 公有方法
+      print(paste("Hello",self$name))
+    }
+  )
+)

> conan <- Person$new('Conan')          # 实例化对象
> conan$hello()                         # 调用用hello()方法
[1] "Hello Conan"

接下来再设置类的私有成员,给Person类中增加private参数,并在公有函数有调用私有成员变量,调用私有成员变量时,要通过private对象进行访问。


> Person <- R6Class("Person",
+   public=list(                       # 公有成员
+     name=NA,
+     initialize = function(name,gender){
+       self$name <- name
+       private$gender<- gender        # 给私有属性赋值
+     },
+     hello = function(){
+       print(paste("Hello",self$name))
+       private$myGender()             # 调用私有方法
+     }
+   ),
+   private=list(                      # 私有成员
+     gender=NA,
+     myGender=function(){
+       print(paste(self$name,"is",private$gender))
+     }
+   )
+ )
> conan <- Person$new('Conan','Male')         # 实例化对象
> conan$hello()                               # 调用用hello()方法
[1] "Hello Conan"
[1] "Conan is Male"

在给Person类中增加私有成员时,通过private参数定义gender的私有属性和myGender()的私有方法。之得注意的是在类的内部,要访问私有成员时,需要用private对象进行调用。

那我直接访问公有属性和私有属性时,公有属性返回正确,而私有属性就是NULL值,并且访问私有方法不可见。


> conan$name            # 公有属性
[1] "Conan"
> conan$gender          # 私有属性
NULL
> conan$myGender()      # 私有方法
Error: attempt to apply non-function

进一步地,我们看看self对象和private对象,具体是什么。在Person类中,增加公有方法member(),在member()方法中分别打印self对象和private对象。


> Person <- R6Class("Person",
+   public=list(
+     name=NA,
+     initialize = function(name,gender){
+       self$name <- name
+       private$gender<- gender
+     },
+     hello = function(){
+       print(paste("Hello",self$name))
+       private$myGender()
+     },
+     member = function(){              # 用于测试的方法
+       print(self)
+       print(private)
+       print(ls(envir=private))
+     }
+   ),
+   private=list(
+     gender=NA,
+     myGender=function(){
+       print(paste(self$name,"is",private$gender))
+     }
+   )
+ )
>
> conan <- Person$new('Conan','Male')
> conan$member()                            # 执行member()方法
<Person>                                    # print(self)的输出
  Public:
    hello: function
    initialize: function
    member: function
    name: Conan

<environment: 0x0000000008cfc918>          # print(private)的输出
[1] "gender"   "myGender"                  # print(ls(envir=private))的输出

从测试结果,我们可以看出self对象,就是实例化的对象本身。private对象则是一个的环境空间,是self对象所在环境空间的中的一个子环境空间,所以私有成员只能在当前的类中被调用,外部访问私有成员时,就会找不到。在环境空间中保存私有成员的属性和方法,通过环境空间的访问控制让外部调用无法使用私有属性和方法,这种方式是经常被用在R包开发上的技巧。

3. R6类的主动绑定

主动绑定(Active bindings)是R6中一种特殊的函数调用方式,把对函数的访问表现为对属性的访问,主动绑定是属于公有成员。在类定义中,通过设置active参数实现主动绑定的功能,给Person类增加两个主动绑定的函数active和rand。


> Person <- R6Class("Person",
+   public = list(
+     num = 100
+   ),
+   active = list(                      # 主动绑定
+     active  = function(value) {
+       if (missing(value)) return(self$num +10 )
+       else self$num <- value/2
+     },
+     rand = function() rnorm(1)
+   )
+)

> conan <- Person$new()
> conan$num                   # 查看公有属性
[1] 100
> conan$active                # 调用主动绑定的active()函数,结果为 num +10= 100+10=100
[1] 110

给主动绑定的active函数传参数,这里传参数要用赋值符号”<-",而不能是方法调用"()"。


> conan$active<-100    # 传参数
> conan$num            # 查看公有属性num
[1] 50
> conan$active         # 调用主动绑定的active()函数,结果为 num+10=50+10=60
[1] 60
> conan$active(100)    # 如果进行方法调用,其实会提示没有这个函数的
Error: attempt to apply non-function

我们再来调用rand函数,看看执行情况。


> conan$rand           # 调用rand函数
[1] -0.4767338
> conan$rand
[1] 0.1063623
> conan$rand<-99       # 传参出错
Error in (function ()  : unused argument (quote(99))

我们直接使用rand()函数完全没有问题,但给rand()函数传参数的时候就出现了错误,由于rand()函数没有定义参数,所以这个操作是不允许的。

通过主动绑定,可以把函数的行为转换成属性的行为,让类中的函数操作更加灵活。

4. R6类的继承关系

继承是面向对象的基本特征,R6的面向对象系统也是支持继承的。当你创建一个类时,可以继承另一个类做为父类存在。

先创建一个父类Person,包括公有成员和私有成员。


> Person <- R6Class("Person",
+   public=list(                            # 公有成员
+     name=NA,
+     initialize = function(name,gender){
+       self$name <- name
+       private$gender <- gender
+     },
+     hello = function(){
+       print(paste("Hello",self$name))
+       private$myGender()
+     }
+   ),
+   private=list(                           # 私有成员
+     gender=NA,
+     myGender=function(){
+       print(paste(self$name,"is",private$gender))
+     }
+   )
+ )

创建子类Worker继承父类Person,并在子类增加bye()公有方法。


> Worker <- R6Class("Worker",
+   inherit = Person,                # 继承,指向父类
+   public=list(
+     bye = function(){
+       print(paste("bye",self$name))
+     }
+   )
+ )

实例化父类和子类,看看继承关系是不是生效了。


> u1<-Person$new("Conan","Male")        # 实例化父类
> u1$hello()
[1] "Hello Conan"
[1] "Conan is Male"

> u2<-Worker$new("Conan","Male")        # 实例化子类
> u2$hello()
[1] "Hello Conan"
[1] "Conan is Male"
> u2$bye()
[1] "bye Conan"

我们看到继承确实生效了,在子类中我们并没有定义hello()方法,子类实例u2可以直接使用hello()方法。同时,子类u2的bye()方法,到了在父类中定义的name属性,输出结果完全正确的。

接下来,我们在子类中定义父类的同名方法,然后再查看方法的调用,看看是否会出现继承中函数重写的特征。修改Worker类,在子类定义private的属性和方法。


> Worker <- R6Class("Worker",
+   inherit = Person,
+   public=list(
+     bye = function(){
+       print(paste("bye",self$name))
+     }
+   ),
+   private=list(
+     gender=NA,
+     myGender=function(){
+       print(paste("worker",self$name,"is",private$gender))
+     }
+   )
+ )

实例化子类,调用hello()方法。


> u2<-Worker$new("Conan","Male")
> u2$hello()                    # 调用hello()方法
[1] "Hello Conan"
[1] "worker Conan is Male"

由于子类中的myGender()私有方法,覆盖了父类的myGender()私有方法,所以在调用hello()方法时,hello()方法中会调用子类中的myGender()方法实现,而忽略了父类中的myGender()方法。

如果在子类中想调用父类的方法,有一个办法是使用super对象,通过super$xx()的语法进行调用。


> Worker <- R6Class("Worker",
+   inherit = Person,
+   public=list(
+     bye = function(){
+       print(paste("bye",self$name))
+     }
+   ),
+   private=list(
+     gender=NA,
+     myGender=function(){
+       super$myGender()                                      # 调用父类的方法
+       print(paste("worker",self$name,"is",private$gender))
+     }
+   )
+ )

> u2<-Worker$new("Conan","Male")
> u2$hello()
[1] "Hello Conan"
[1] "Conan is Male"
[1] "worker Conan is Male"

在子类myGender()方法中,用super对象调用父类的myGender()方法,从输出可以看出,父类的同名方法也同时被调用了。

5. R6类的对象的静态属性

用面向对象的方法进行编程,那么所有变量其实都是对象,我们可以把一个实例化的对象定义成另一个类的属性,这样就形成了对象的引用关系链。

需要注意的一点是,当属性赋值为另一个R6的对象时,属性的值保存了对象的引用,而非对象实例本身。利用这个规则就可以实现对象的静态属性,也就是可以在多种不同的实例中是共享对象属性,类似于Java中的static属性一样。

下面用代码描述一下,就能很容易的理解。定义两个类A和B,A类中有一个公有属性x,B类中有一个公有属性a,a为A类的实例化对象。


> A <- R6Class("A",
+  public=list(
+    x = NULL
+  )
+ )
>
> B <- R6Class("B",
+  public = list(
+    a = A$new()
+  )
+ )

运行程序,实现B实例化对象对A实例化对象的调用,并给x变量赋值。


> b <- B$new()         # 实例化B对象
> b$a$x <- 1           # 给x变量赋值
> b$a$x                # 查看x变量的值
[1] 1

> b2 <- B$new()        # 实例化b2对象
> b2$a$x <- 2          # 给x变量赋值
> b2$a$x               # 查看x变量的值
[1] 2

> b$a$x                # b实例的a对象的x值也发生改变
[1] 2

从输出结果可以看到,a对象实现了在多个b实例的共享,当b2实例修改a对象x值的时候,b实例的a对象的x值也发生了变化。

这里有一种写法,我们是应该要避免的,就是通过initialize()方法赋值。


> C <- R6Class("C",
+  public = list(
+    a = NULL,
+    initialize = function() {
+      a <<- A$new()
+    }
+  )
+ )

> cc <- C$new()
> cc$a$x <- 1
> cc$a$x
[1] 1

> cc2 <- C$new()
> cc2$a$x <- 2
> cc2$a$x
[1] 2

> cc$a$x        # x值未发生改变
[1] 1

通过initialize()构建是的a对象,是对单独的环境空间中的引用,所以不能实现引用对象的共享。

6. R6类的可移植类型

在R6类的定义中,portable参数可以设置R6类的类型为可移植类型和不可移植类型。可移植类型和不可移植类型主要有2个明显的特征。

  • 可移植类型支持跨R包的继承;不可移植类型,在跨R包继承的时候,兼容性不太好。
  • 可移植类型必须要用self对象和private对象来访问类中的成员,如self$x,private$y;不可移植类型,可以直接使用变量x,y,并通过<<-实现赋值。

本文中使用的是R6的最新版本2.0,所以默认创建的是可移植类型。所以,当我们要考虑是否有跨包继承的需求时,可以在可移植类型和不可移植类型之间进行选择。

我们比较一下RC类型,R6的可移植类型和R6的不可移植类型三者的区别,定义一个简单的类,包括一个属性x和两个方法getx(),setx()。


> RC <- setRefClass("RC",                  # RC类型的定义
+   fields = list(x = 'Hello'),
+   methods = list(
+     getx = function() x,
+     setx = function(value) x <<- value
+   )
+ )
> rc <- RC$new()
> rc$setx(10)
> rc$getx()
[1] 10

创建一个行为完全一样的不可移植类型的R6类。


> NR6 <- R6Class("NR6",                # R6不可移植类型
+   portable = FALSE,
+   public = list(
+     x = NA,
+     getx = function() x,
+     setx = function(value) x <<- value
+   )
+ )
> np6 <- NR6$new()
> np6$setx(10)
> np6$getx()
[1] 10

再创建一个行为完全一样的可移植类型的R6类。


> PR6 <- R6Class("PR6",
+   portable = TRUE,            # R6可移植类型
+   public = list(
+    x = NA,
+    getx = function() self$x,
+    setx = function(value) self$x <- value
+   )
+ )
> pr6 <- PR6$new()
> pr6$setx(10)
> pr6$getx()
[1] 10

从这个例子中,可移植类型的R6类和不可移植类型的区别在,就在于self对象的使用。

7. R6类的动态绑定

对于静态类型的编程语言来说,一旦类定义后,就不能再修改类中的属性和方法,像反射这样的高开销的特殊操作除外。 而对于动态类型的编程语言来说,通常不存在这样的限制,可以任意修改其类的结构或者已实例化的对象的结构。 R作为动态语言来说,同样是支持动态变量修改的,基于S3类型和S4类型可以通过泛型函数动态地增加函数定义,但RC类型是不支持的,再次感觉到了R语言中面向对象系统设计的奇葩了。

R6包已考虑这个情况,提供了一种动态设置成员变量的方法用$set()函数。


> A <- R6Class("A",
+   public = list(
+     x = 1,
+     getx = function() x
+   )
+ )
> A$set("public", "getx2", function() self$x*2)     # 动态增加getx2()方法
> s <- A$new()
> s                     # 查看实例化对象的结构
<A>
  Public:
    getx: function
    getx2: function
    x: 1
> s$getx2()             # 调用getx2()方法
[1] 20

同样地,属性也可以动态修改,动态改变x属性的值。


> A$set("public", "x", 10, overwrite = TRUE)     # 动态改变x属性
> s <- A$new()
> s$x                                            # 查看x属性
[1] 10
> s$getx()                                       # 调用getx()方法,可移植类型x变量丢失
Error in s$getx() : object 'x' not found

由于A类默认是可移植类型的,所以在使用x变量时应该通过self对象来访问,否则动态成员修改的时候,就会出现错误,我们把getx中的x改为self$x。


> A <- R6Class("A",
+  public = list(
+    x = 1,
+    getx = function() self$x     # 修改为self$x
+  )
+ )
> A$set("public", "x", 10, overwrite = TRUE)
> s <- A$new()
> s$x
[1] 10
> s$getx()                        # 调用getx()方法
[1] 10

对于可移植类型和不可移植类型,建议大家养成习惯都使用self和private对象进行访问。

8. R6类的打印函数

R6提供了用于打印的默认方法print(),每当要打印实例化对象时,都会调用这个默认的print()方法,有点类似于Java类中默认的toString()方法。

我们可以覆盖print()方法,使用自定义的打印提示。


> A <- R6Class("A",
+  public = list(
+    x = 1,
+    getx = function() self$x
+  )
+ )
> a <- A$new()
> print(a)             # 使用默认的打印方法
<A>
  Public:
    getx: function
    x: 1

自定义打印方法,覆盖print()方法。


> A <- R6Class("A",
+    public = list(
+      x = 1,
+      getx = function() self$x,
+      print = function(...) {
+        cat("Class <A> of public ", ls(self), " :", sep="")
+        cat(ls(self), sep=",")
+        invisible(self)
+      }
+    )
+ )
> a <- A$new()
> print(a)
Class <A> of public getxprintx :getx,print,x

通过自定义的方法,就可以覆盖系统默认的方法,从而输出我们想显示的文字。

9. 实例化对象的存储

R6是基于S3面向对象系统的构建,而S3类型又是一种比较松散的类型,会造成用户环境空间的变量泛滥的问题。R6提供了一种方式,设置R6Class()的class参数,把类中定义的属性和方法统一存储到一个S3对象中,这种方式是默认的。另一种方式为,把把类中定义的属性和方法统一存储到一个单独的环境空间中。

我们看查看一下默认的情况,class=TRUE,实例化后的a对象,就是一个S3的类。


> A <- R6Class("A",
+  class=TRUE,
+  public = list(
+    x = 1,
+    getx = function() self$x
+  )
+ )
> a <- A$new()
> class(a)
[1] "A"  "R6"
> a
<A>
  Public:
    getx: function
    x: 1

当class=FALSE时,实例化后的a对象,是一个环境空间,在环境空间中存储了类的变量数据。


> B <- R6Class("B",
+   class=FALSE,
+   public = list(
+     x = 1,
+     getx = function() self$x
+   )
+ )
> b <- B$new()
> class(b)
[1] "environment"
> b
<environment: 0x000000000d83c970>
> ls(envir=b)
[1] "getx" "x"

实例化对象的存储还有另外一方面的考虑,由于类中的变量都是存在于一个环境空间中的,我们也可以通过手动的方式找到这个环境空间,从而进行变量的增加或修改。 如果随意地对环境空间中的变量进行修改,那么会给我们的程序带来一些安全上的风险,所以为了预防安全上的问题,可以通过R6Class()的lock参数所定环境空间,不允许动态修改,默认值为锁定状态不能修改。


> A <- R6Class("A",
+   lock=TRUE,       # 锁定环境空间
+   public = list(
+     x = 1
+   )
+ )
> s<-A$new()
> ls(s)         # 查看s环境空间的变量
[1] "x"
> s$aa<-11      # 增加新变量,错误
Error in s$aa <- 11 : cannot add bindings to a locked environment
> rm("x",envir=s)       # 删除原有变量,错误
Error in rm("x", envir = s) :
  cannot remove bindings from a locked environment

如果不锁定环境空间,让lock=FALSE,则环境空间处于完全开放的状态,可以任意进行变量的修改。


> A <- R6Class("A",
+  lock=FALSE,         # 不锁定环境空间
+  public = list(
+    x = 1
+  )
+ )
> s<-A$new()
> ls(s)         # 查看s环境空间的变量
[1] "x"
> s$aa<-11      # 增加变量
> ls(s)
[1] "aa" "x"
> rm("x",envir=s)    # 删除变量
> ls(s)
[1] "aa"

通过上面对R6的介绍,我就基本掌握R6面向对象系统的知识。接下来,我们做一个简单的例子,应用一下R6的面向对象编程。

10. R6面向对象系统的案例

我们用R6的面向对象系统,来构建一个图书分类的使用案例。

任务一:定义图书的静态结构

以图书(book)为父类,包括R,Java,PHP 的3个分类,在book类中定义私有属性及公有方法。

r6-class

定义图书系统的数据结构,包括父类的结构 和 3种型类的图书。


> Book <- R6Class("Book",            # 父类
+    private = list(
+      title=NA,
+      price=NA,
+      category=NA
+    ),
+   public = list(
+     initialize = function(title,price,category){
+       private$title <- title
+       private$price <- price
+       private$category <- category
+     },
+     getPrice=function(){
+       private$price
+     }
+   )
+ )

> R <- R6Class("R",     # 子类R图书
+    inherit = Book
+ )
> Java <- R6Class("JAVA",  # 子类JAVA图书
+   inherit = Book
+ )
> Php <- R6Class("PHP",    # 子类PHP图书
+   inherit = Book
+ )

创建3个实例化对象,R语言图书《R的极客理想-工具篇》,JAVA语言图书《Java编程思想》,PHP语言图书《Head First PHP & MySQL》,并获得图书的定价。


> r1<-R$new("R的极客理想-工具篇",59,"R")
> r1$getPrice()
[1] 59

> j1<-Java$new("Java编程思想",108,"JAVA")
> j1$getPrice()
[1] 108

> p1<-Java$new("Head First PHP & MySQL",98,"PHP")
> p1$getPrice()
[1] 98

任务二:正逢双11对各类图书打折促销

我们设计一种打折规则,用来促进图书的销售,这个规则纯属虚构。

  • 所有图书9折
  • JAVA图书7折,不支持重复打折
  • 为了推动R图书的销售,R语言图书7折,并支持重复打折
  • PHP图书无特别优惠

根据打折规则,图书都可以被打折,那么打折就可以作为图书对象的一个行为,然后R, Java, PHP的3类图书,分别还有自己的打折规则,所以是一种多态的表现。

我们修改父类的定义,增加打折的方法discount(),默认设置为9折,满足第一条规则。


> Book <- R6Class("Book",
+   private = list(
+     title=NA,
+     price=NA,
+     category=NA
+   ),
+   public = list(
+     initialize = function(title,price,category){
+       private$title <- title
+       private$price <- price
+       private$category <- category
+     },
+     getPrice=function(){
+       p<-private$price*self$discount()
+       print(paste("Price:",private$price,", Sell out:",p,sep=""))
+     },
+     discount=function(){
+       0.9
+     }
+   )
+ )

3个子类,分别对应自己的打折规则,分别进行修改。

  • 给JAVA子类增加 discount()方法,用于覆盖父类的discount()方法,让JAVA图书7折,不支持重复打折,从而满足第二条规则。
  • 给R子类增加 discount()方法,在子类的discount()方法中调用父类的discount()方法,让支持 R图书7折和9折的折上折,从而满足第三条规则。
  • PHP子类,没有修改,完全遵循第一条规则的。
    • 
      > Java <- R6Class("JAVA",
      +   inherit = Book,
      +   public = list(
      +     discount=function(){
      +       0.7
      +     }
      +   )    
      + )
      > 
      > R <- R6Class("R",
      +   inherit = Book,
      +   public = list(
      +     discount=function(){
      +       super$discount()*0.7
      +     }
      +   )             
      + )
      > 
      > Php <- R6Class("PHP",
      +   inherit = Book       
      + )
      

      分别查看3本图书的折后价格。

      
      > r1<-R$new("R的极客理想-工具篇",59,"R")
      > r1$getPrice()
      [1] "Price:59, Sell out:37.17"   # 59 * 0.9 *0.7= 37.17
      >
      > j1<-Java$new("Java编程思想",108,"JAVA")
      > j1$getPrice()
      [1] "Price:108, Sell out:75.6"    # 108 *0.7= 75.6
      >
      > p1<-Php$new("Head First PHP & MySQL",98,"PHP")
      > p1$getPrice()
      [1] "Price:98, Sell out:88.2"      # 98 *0.9= 88.2
      

      R图书打折最多,享受7折和9折的折上折优惠, 59 * 0.9 * 0.7= 37.17;Java图书享受7折优惠,108 *0.7= 75.6;PHP图书享受9折优惠 98 *0.9= 88.2。

      通过这个实例,我们用R6的方法实现了面向对象编程中的封装、继承和多态的3个特征,证明R6是一种完全的面向对象的实现。R6类对象系统,提供了一种可兼容的面向对象实现方式,更接近于其他的编程语言上的面向对象的定义,由于R6底层基于S3来实现的,所以比RC的类更加有效果。

      我们一共介绍了4种R语言的面向对象体系结构,选择自己理解的,总有一种会适合你。

      转载请注明出处:
      http://blog.fens.me/r-class-r6/

      打赏作者

R语言游戏框架设计

R的极客理想系列文章,涵盖了R的思想,使用,工具,创新等的一系列要点,以我个人的学习和体验去诠释R的强大。

R语言作为统计学一门语言,一直在小众领域闪耀着光芒。直到大数据的爆发,R语言变成了一门炙手可热的数据分析的利器。随着越来越多的工程背景的人的加入,R语言的社区在迅速扩大成长。现在已不仅仅是统计领域,教育,银行,电商,互联网….都在使用R语言。

要成为有理想的极客,我们不能停留在语法上,要掌握牢固的数学,概率,统计知识,同时还要有创新精神,把R语言发挥到各个领域。让我们一起动起来吧,开始R的极客理想。

关于作者:

  • 张丹(Conan), 程序员Java,R,PHP,Javascript
  • weibo:@Conan_Z
  • blog: http://blog.fens.me
  • email: bsspirit@gmail.com

转载请注明出处:
http://blog.fens.me/r-game-framework/

r-game-framework

前言

本文继续上一篇文章 R语言游戏之旅 贪食蛇入门。当我们完成了贪食蛇游戏之后,我们应该把代码进一步整理,抽象出游戏中通用的部分,分离游戏框架代码和贪食蛇游戏代码。我们就可以提取出一个R语言的游戏开发引擎,当再开发新的游戏时,只要关心游戏本身的程序设计就行了。

目录

  1. 贪食蛇的面向对象改造
  2. 游戏框架定义
  3. 在框架中重新实现贪食蛇游戏

1. 贪食蛇的面向对象改造

我们可以利用面向对象的方法论,对贪食蛇游戏进行抽象整理,并实现代码的面向对象的改造。R语言支持3种面向对象的编程实现方式,我选择基于RC的面向对象编程,关于RC详细使用请参考文章:R语言基于RC的面向对象编程

由于我们之前的代码都是通过函数来封装的,所以代码重构还是比较简单的,只要把Snake对象的属性和方法定义清楚就行了。

1.1 定义Snake类

定义Snake类,画出类图,包括属性和方法。

class1

属性解释:

  • name:游戏的名字
  • stage:当前的游戏场景
  • e:游戏中的变量,environment类型
  • m:游戏地图矩阵
  • width:矩阵的宽
  • height:矩阵的高

方法解释:

  • initialize():构建函数,用于RC类的初始化
  • init():给stage1场景初始化游戏变量
  • fail():失败查询
  • furit():判断并生成水果坐标
  • head():生成蛇头移动坐标。
  • body():生成蛇尾移动坐标。
  • drawTable():绘制游戏背景。
  • drawMatrix():绘制游戏矩阵。
  • stage0():创建开机场景,可视化输出。
  • stage1():创建游戏场景,stage1()函数内部,封装了游戏场景运行时的函数,并进行调用。
  • stage2():创建结束场景,可视化输出
  • keydown():监听键盘事件。
  • run():启动函数

1.2 全局函数调用顺序图

接下来,根据UML规范画出顺序图,主要包括全局函数调用和stage1场景游戏环境调用。

全局函数调用关系。

  1. 通过run()函数启动游戏,进入stage0场景,注册键盘事件。
  2. 在stage0场景按任意键切换到stage1场景。
  3. init()出始化stage1场景的游戏变量。
  4. stage1()运行游戏
  5. 当游戏失败fail()或按q键
  6. 游戏进行stage2场景,显示游戏结束画面,
  7. 按空格键回到stage0重新开始,按q键退出程序。

seq1

1.3 stage1场景游戏环境函数调用顺序图

stage1场景游戏环境函数调用关系。

  1. 游戏进入stage1场景,按上下左右(up,down,left,right)方向键操作蛇头的前进路线。
  2. furit()函数检查,如果地图上水果被吃掉,生成一个新水果,记录到矩阵中。
  3. head()函数,通过上下左边键的操作,进行蛇头的移动,记录到矩阵中。
  4. fail()函数失败检查,no未失败继续,yes失败进行stage2场景。
  5. body()函数,蛇身体移动,记录到矩阵中。
  6. drawTable()函数,画出游戏背景画布。
  7. drawMatrix()函数,画出游戏矩阵。

seq2

利用UML的方法,通过类图和顺序图的描述,我们就把贪食蛇的游戏程序进行了面向对象的设计改造。不用着急去写代码,我们再想想如何进行游戏框架的提取。

2. 游戏框架定义

要设计一个完整、易用、有良好扩展的游戏框架是比难的,但我们可以基于贪食蛇的游戏,一步一步来做抽象。抽象过程就是把程序对象化,上面的我们已经做了;第二步再把公用的属性和方法提取封装,可以统一把公用的部分提取到一个Game的父类里面,让Snake类继承Game类,从而实现游戏框架定义。我们画出Game类和Snake类的类图。

class2

  • Game类公共属性,包括了所有的Snake类的属性,这是因为这些属性都是全局的,其他的游戏也会用到,而且每个游戏中的属性,可以在e中进行定义。
  • Game类公共方法,包括了游戏全局调用的方法,但不包括Snake游戏stage1场景中运行的方法。在Game类的方法中,我们主要实现的都是开发的辅助功能。
  • Snake类方法,同样还有Game类的方法,这是用到方法的重写技术。子类的方法,先调用父类的同名方法,然后再执行子类方法里的程序。

这样我们就简单地分离了游戏框架Game类和游戏实现Snake类,下面我们要做的就是把代码按照设计进行实现,看看我们的设计是否是合理的。

3. 在框架中重新实现贪食蛇游戏

Game类的代码实现,用R语言的RC面向对象编程进行代码编写。


Game<-setRefClass('Game',
                  
    fields=list(
      # 系统变量
      name="character", # 名字
      debug='logical',  # 调试状态
      width='numeric',  # 矩阵宽
      height='numeric', # 矩阵高
      
      # 应用变量
      stage='numeric',  # 场景
      e='environment',  # 环境空间变量
      m='matrix',       # 数据矩阵
      isFail='logical'  # 游戏失败
    ),
                  
    methods=list(
      
      # 构造函数
      initialize = function(name,width,height,debug) {
        name<<-"R Game Framework"
        debug<<-FALSE
        width<<-height<<-20   #矩阵宽高
      },
      
      # 初始化变量
      init = function(){
        e<<-new.env()   #环境空间
        m<<-matrix(rep(0,width*height),nrow=width)  #数据矩阵
        isFail<<-FALSE
      },
      
      # 开机画图
      stage0=function(){
        stage<<-0
        init()
      },
      
      # 结束画图
      stage2=function(){
        stage<<-2
      },
      
      # 游戏中
      stage1=function(default=FALSE){
        stage<<-1
        if(FALSE){  # 默认游戏中界面
          plot(0,0,xlim=c(0,1),ylim=c(0,1),type='n',xaxs="i", yaxs="i")
          text(0.5,0.7,label="Playing",cex=5)  
        }
      },
      
      # 矩阵工具
      index = function(col) {
        return(which(m==col))
      },
      
      # 失败操作
      fail=function(msg){
        print(paste("Game Over",msg))
        isFail<<-TRUE
        keydown('q')
        return(NULL)
      },
      
      # 键盘事件,控制场景切换
      keydown=function(K){
        if(stage==0){ #开机画面
          stage1()
          return(NULL)
        }  
        
        if(stage==2){ #结束画面
          if(K=="q") q()
          else if(K==' ') stage0()  
          return(NULL)
        } 
      },
      
      # 启动程序
      run=function(){
        par(mai=rep(0,4),oma=rep(0,4))
        stage0()
        getGraphicsEvent(prompt="Snake Game",onKeybd=function(K){
          if(debug) print(paste("keydown",K))  
          return(keydown(K))
        })
      }
    )                  
)

Snake类的代码实现,继承Game类,并实现贪食蛇游戏的私有方法。


# 引用game.r文件
source(file="game.r")

# Snake类,继承Game类
Snake<-setRefClass("Snake",contains="Game",
                   
   methods=list(
     
     # 构造函数
     initialize = function(name,width,height,debug) {
       callSuper(name,width,height,debug) # 调父类
       
       name<<-"Snake Game"
     },
     
     # 初始化变量
     init = function(){
       callSuper()  # 调父类
       
       e$step<<-1/width #步长
       e$dir<<-e$lastd<<-'up' # 移动方向
       e$head<<-c(2,2) #初始蛇头坐标
       e$lastx<<-e$lasty<<-2 # 蛇头上一个点坐标
       e$tail<<-data.frame(x=c(),y=c())#初始蛇尾坐标
       
       e$col_furit<<-2 #水果颜色
       e$col_head<<-4 #蛇头颜色
       e$col_tail<<-8 #蛇尾颜色
       e$col_path<<-0 #路颜色
       e$col_barrier<<-1 #障碍颜色
     },
     
     # 失败检查
     lose=function(){
       # head出边界
       if(length(which(e$head<1))>0 | length(which(e$head>width))>0){
         fail("Out of ledge.")
         return(NULL)
       }
       
       # head碰到tail
       if(m[e$head[1],e$head[2]]==e$col_tail){
         fail("head hit tail.")
         return(NULL)
       }
     },
     
     # 随机的水果点
     furit=function(){
       if(length(index(e$col_furit))<=0){ #不存在水果
         idx<-sample(index(e$col_path),1)
         
         fx<-ifelse(idx%%width==0,10,idx%%width)
         fy<-ceiling(idx/height)
         m[fx,fy]<<-e$col_furit
         
         if(debug){
           print(paste("furit idx",idx))
           print(paste("furit axis:",fx,fy))
         }
       }
     },
     
     # snake head
     head=function(){
       e$lastx<<-e$head[1]
       e$lasty<<-e$head[2]
       
       # 方向操作
       if(e$dir=='up') e$head[2]<<-e$head[2]+1
       if(e$dir=='down') e$head[2]<<-e$head[2]-1
       if(e$dir=='left') e$head[1]<<-e$head[1]-1
       if(e$dir=='right') e$head[1]<<-e$head[1]+1
     },
     
     # snake body
     body=function(){
       if(isFail) return(NULL)
       
       m[e$lastx,e$lasty]<<-e$col_path
       m[e$head[1],e$head[2]]<<-e$col_head #snake
       if(length(index(e$col_furit))<=0){ #不存在水果
         e$tail<<-rbind(e$tail,data.frame(x=e$lastx,y=e$lasty))
       }
       
       if(nrow(e$tail)>0) { #如果有尾巴
         e$tail<<-rbind(e$tail,data.frame(x=e$lastx,y=e$lasty))
         m[e$tail[1,]$x,e$tail[1,]$y]<<-e$col_path
         e$tail<<-e$tail[-1,]
         m[e$lastx,e$lasty]<<-e$col_tail
       }
       
       if(debug){
         print(paste("snake idx",index(e$col_head)))
         print(paste("snake axis:",e$head[1],e$head[2]))  
       }
     },
     
     # 画布背景
     drawTable=function(){
       if(isFail) return(NULL)
       
       plot(0,0,xlim=c(0,1),ylim=c(0,1),type='n',xaxs="i", yaxs="i")
       
       if(debug){
         # 显示背景表格
         abline(h=seq(0,1,e$step),col="gray60") # 水平线
         abline(v=seq(0,1,e$step),col="gray60") # 垂直线
         # 显示矩阵
         df<-data.frame(x=rep(seq(0,0.95,e$step),width),y=rep(seq(0,0.95,e$step),each=height),lab=seq(1,width*height))
         text(df$x+e$step/2,df$y+e$step/2,label=df$lab)
       }
     },
     
     # 根据矩阵画数据
     drawMatrix=function(){
       if(isFail) return(NULL)
       
       idx<-which(m>0)
       px<- (ifelse(idx%%width==0,width,idx%%width)-1)/width+e$step/2
       py<- (ceiling(idx/height)-1)/height+e$step/2
       pxy<-data.frame(x=px,y=py,col=m[idx])
       points(pxy$x,pxy$y,col=pxy$col,pch=15,cex=4.4)
     },
     
     # 游戏场景
     stage1=function(){
       callSuper()
       
       furit()
       head()
       lose()
       body()
       drawTable()
       drawMatrix()  
     },
     
     # 开机画图
     stage0=function(){
       callSuper()
       plot(0,0,xlim=c(0,1),ylim=c(0,1),type='n',xaxs="i", yaxs="i")
       text(0.5,0.7,label=name,cex=5)
       text(0.5,0.4,label="Any keyboard to start",cex=2,col=4)
       text(0.5,0.3,label="Up,Down,Left,Rigth to control direction",cex=2,col=2)
       text(0.2,0.05,label="Author:DanZhang",cex=1)
       text(0.5,0.05,label="http://blog.fens.me",cex=1)
     },
     
     # 结束画图
     stage2=function(){
       callSuper()
       info<-paste("Congratulations! You have eat",nrow(e$tail),"fruits!")
       print(info)
       
       plot(0,0,xlim=c(0,1),ylim=c(0,1),type='n',xaxs="i", yaxs="i")
       text(0.5,0.7,label="Game Over",cex=5)
       text(0.5,0.4,label="Space to restart, q to quit.",cex=2,col=4)
       text(0.5,0.3,label=info,cex=2,col=2)
       text(0.2,0.05,label="Author:DanZhang",cex=1)
       text(0.5,0.05,label="http://blog.fens.me",cex=1)
     },
     
     # 键盘事件,控制场景切换
     keydown=function(K){
       callSuper(K)
       
       if(stage==1){ #游戏中
         if(K == "q") stage2()
         else {
           if(tolower(K) %in% c("up","down","left","right")){
             e$lastd<<-e$dir
             e$dir<<-tolower(K)
             stage1()  
           }
         }
         return(NULL)
       }
       return(NULL)
     }
   )                   
)

snake<-function(){
  game<-Snake$new()
  game$initFields(debug=TRUE)
  game$run()
}

snake()

最后,我们运行snake.r的程序,就完成了整个贪食蛇游戏。游戏运行效果,可以查看上一篇文章,R语言游戏之旅 贪食蛇入门 的游戏截图和动画。

对于贪食蛇游戏的开发,我们已经完成了,虽然界面还是比较土,而且没有时间维度的操作。那么我们换一个角度思考,如果不太要求画面效果,而且不需要时间维度的游戏,是不是R语言会表现的更好呢?当然,这类游戏也有很多,比如最近流行的2048。那么接下来,就用我们的游戏框架,再来做一个2048的游戏吧,试试在100行之内实现。

转载请注明出处:
http://blog.fens.me/r-game-framework/

打赏作者

R语言基于RC的面向对象编程

R的极客理想系列文章,涵盖了R的思想,使用,工具,创新等的一系列要点,以我个人的学习和体验去诠释R的强大。

R语言作为统计学一门语言,一直在小众领域闪耀着光芒。直到大数据的爆发,R语言变成了一门炙手可热的数据分析的利器。随着越来越多的工程背景的人的加入,R语言的社区在迅速扩大成长。现在已不仅仅是统计领域,教育,银行,电商,互联网….都在使用R语言。

要成为有理想的极客,我们不能停留在语法上,要掌握牢固的数学,概率,统计知识,同时还要有创新精神,把R语言发挥到各个领域。让我们一起动起来吧,开始R的极客理想。

关于作者:

  • 张丹(Conan), 程序员Java,R,PHP,Javascript
  • weibo:@Conan_Z
  • blog: http://blog.fens.me
  • email: bsspirit@gmail.com

转载请注明出处:
http://blog.fens.me/r-class-rc/

r-oo-rc

前言

本文接上一篇文章 R语言基于S4的面向对象编程,本文继续介绍R语言基于RC的面向对象编程。

RC对象系统从底层上改变了原有S3和S4对象系统的设计,去掉了泛型函数,真正地以类为基础实现面向对象的特征。

目录

  1. RC对象系统介绍
  2. 创建RC类和对象
  3. 对象赋值
  4. 定义对象的方法
  5. RC对象内置方法
  6. RC类的辅助构造函数
  7. RC对象系统的使用

1 RC对象系统介绍

RC是Reference classes的简称,又被称为R5,在R语言的2.12版本被引入的,是最新一代的面向对象系统。

RC不同于原来的S3和S4对象系统,RC对象系统的方法是在类中自定的,而不是泛型函数。RC对象的行为更相似于其他的编程语言,实例化对象的语法也有所改变。

从面向对象的角度来说,我们下面要重定义几个名词。

  • 类:面向对象系统的基本类型,类是静态结构定义。
  • 对象:类实例化后,在内存中生成结构体。
  • 方法:是类中的函数定义,不通过泛型函数实现。

2 创建RC类和对象

本文的系统环境

  • Linux: Ubuntu Server 12.04.2 LTS 64bit
  • R: 3.0.1 x86_64-pc-linux-gnu

为了方便我们检查对象的类型,引入pryr包作为辅助工具。关于pryr包的介绍,请参考文章:[撬动R内核的高级工具包pryr](http://blog.fens.me/r-pryr/)


# 加载pryr包
> library(pryr)

2.1 如何创建RC类?

RC对象系统是以类为基本类型, 有专门的类的定义函数 setRefClass() 和 实例化则通过类的方法生成,我们一下如何用RC对象系统创建一个类。

2.1.1 setRefClass()

查看setRefClass的函数定义。


setRefClass(Class, fields = , contains = , methods =, where =, ...)

参数列表:

  • Class: 定义类名
  • fields: 定义属性和属性类型
  • contains: 定义父类,继承关系
  • methods: 定义类中的方法
  • where: 定义存储空间

从setRefClass()函数的定义来看,参数比S4的setClass()函数变少了。

2.2 创建RC类和实例


# 定义一个RC类
> User<-setRefClass("User",fields=list(name="character"))

# 查看User的定义
> User
Generator for class "User":

Class fields:
Name:       name
Class: character

Class Methods:
"callSuper", "copy", "export", "field", "getClass",
"getRefClass", "import", "initFields", "show", "trace",
"untrace", "usingMethods"

Reference Superclasses:
"envRefClass"


# 实例化一个User对象u1
> u1<-User$new(name="u1")

# 查看u1对象
> u1
Reference class object of class "User"
Field "name":
[1] "u1"

# 检查User类的类型
> class(User)
[1] "refObjectGenerator"
attr(,"package")
[1] "methods"
> is.object(User)
[1] TRUE
> otype(User)
[1] "RC"

# 检查u1的类型
> class(u1)
[1] "User"
attr(,"package")
[1] ".GlobalEnv"
> is.object(u1)
[1] TRUE
> otype(u1)
[1] "RC"

2.3 创建一个有继承关系的RC类


# 创建RC类User
> User<-setRefClass("User",fields=list(name="character"))

# 创建User的子类Member
> Member<-setRefClass("Member",contains="User",fields=list(manager="User"))

# 实例化User
> manager<-User$new(name="manager")

# 实例化一个Son对象
> member<-Member$new(name="member",manager=manager)

# 查看member对象
> member
Reference class object of class "Member"
Field "name":
[1] "member"
Field "manager":
Reference class object of class "User"
Field "name":
[1] "manager"

# 查看member对象的name属性
> member$name
[1] "member

# 查看member对象的manager属性
> member$manager
Reference class object of class "User"
Field "name":
[1] "manager"

# 检查对象的属性类型
> otype(member$name)
[1] "primitive"
> otype(member$manager)
[1] "RC"

2.4 RC对象的默认值

RC的类有一个指定构造器方法 $initialize(),这个构造器方法在实例化对象时,会自动被运行一次,通过这个构造方法可以设置属性的默认值。


# 定义一个RC类
> User<-setRefClass("User",
+
+     # 定义2个属性
+     fields=list(name="character",level='numeric'),
+     methods=list(
+
+          # 构造方法
+          initialize = function(name,level){
+              print("User::initialize")
+
+              # 给属性增加默认值
+              name <<- 'conan'
+              level <<- 1
+           }
+      )
+ )

# 实例化对象u1
> u1<-User$new()
[1] "User::initialize"

# 查看对象u1,属性被增加了默认值
> u1
Reference class object of class "User"
Field "name":
[1] "conan"
Field "level":
[1] 1

3 对象赋值


# 定义User类
> User<-setRefClass("User",fields=list(name="character",age="numeric",gender="factor"))

# 定义一个factor类型
> genderFactor<-factor(c('F','M'))

# 实例化u1
> u1<-User$new(name="u1",age=44,gender=genderFactor[1])

# 查看age属性值
> u1$age
[1] 44

给u1的age属性赋值。


# 重新赋值
> u1$age<-10

# age属性改变
> u1$age
[1] 10

把u1对象赋值给u2对象。


# 把u1赋值给u2对象
> u2<-u1

# 查看u2的age属性
> u2$age
[1] 10

# 重新赋值
> u1$age<-20

# 查看u1,u2的age属性,都发生改变
> u1$age
[1] 20
> u2$age
[1] 20

这是由于把u1赋值给u2的时候,传递的是u1的实例化对象的引入,而不是值本身。这一点与其他语言中对象赋值是一样的。

如果想进行赋值而不是引入传递,可以用下面的方法实现。


# 调用u1的内置方法copy(),赋值给u3
> u3<-u1$copy()

# 查看u3的age属性
> u3$age
[1] 20

# 重新赋值
> u1$age<-30

# 查看u1的age属性,发生改变
> u1$age
[1] 30

# 查看u3的age属性,没有改变
> u3$age
[1] 20

对引入关系把握,可以减少值传递过程中的内存复制过程,可以让我们的程序运行效率更高。

4 定义对象的方法

在S3,S4的对象系统中,我们实现对象的行为时,都是借助于泛型函数来实现的。这种现实方法的最大问题是,在定义时函数和对象的代码是分离的,需要在运行时,通过判断对象的类型完成方法调用。而在RC对象系统中,方法可以定义在类的内部,通过实例化的对象完成方法调用。


# 定义一个RC类,包括方法
> User<-setRefClass("User",
+       fields=list(name="character",favorite="vector"),
+
+       # 方法属性
+       methods = list(
+
+           # 增加一个兴趣
+           addFavorite = function(x) {
+                 favorite <<- c(favorite,x)
+           },
+
+           # 删除一个兴趣
+           delFavorite = function(x) {
+                 favorite <<- favorite[-which(favorite == x)]
+           },
+
+           # 重新定义兴趣列表
+           setFavorite = function(x) {
+                 favorite <<- x
+           }
+       )
+ )

# 实例化对象u1
> u1<-User$new(name="u1",favorite=c('movie','football'))

# 查看u1对象
> u1
Reference class object of class "User"
Field "name":
[1] "u1"
Field "favorite":
[1] "movie"    "football"

接下来,进行方法操作。


# 删除一个兴趣
> u1$delFavorite('football')

# 查看兴趣属性
> u1$favorite
[1] "movie"

# 增加一个兴趣
> u1$addFavorite('shopping')
> u1$favorite
[1] "movie"    "shopping"

# 重置兴趣列表
> u1$setFavorite('reading')
> u1$favorite
[1] "reading"

直接到方法定义到类的内部,通过实例化的对象进行访问。这样就做到了,在定义时就能保证了方法的作用域,减少运行时检查的系统开销。

5 RC对象内置方法和内置属性

对于RC的实例化对象,除了我们自己定义的方法函数,还有几个内置的方法。之前属性复制赋值时使用的copy()方法,就是其中之一。

5.1 内置方法:

  • initialize 类的初始化函数,用于设置属性的默认值,只能在类定义的方法中使用。
  • callSuper 调用父类的同名方法,只能在类定义的方法中使用。
  • copy 复制实例化对象的所有属性。
  • initFields 给对象的属性赋值。
  • field 查看属性或给属性赋值。
  • getClass 查看对象的类定义。
  • getRefClass 同getClass。
  • show 查看当前对象。
  • export 查看属性值以类为作用域。
  • import 把一个对象的属性值赋值给另一个对象。
  • trace 跟踪对象中方法调用,用于程序debug。
  • untrace 取消跟踪。
  • usingMethods 用于实现方法调用,只能在类定义的方法中使用。这个方法不利于程序的健壮性,所以不建议使用。

接下来,我们使用这些内置的方法。

首先定义一个父类User,包括 name和level两个属性, addLevel和addHighLevel两个功能方法,initialize构造方法。


# 类User
> User<-setRefClass("User",
+    fields=list(name="character",level='numeric'),
+    methods=list(
+      initialize = function(name,level){
+        print("User::initialize")
+        name <<- 'conan'
+        level <<- 1
+      },
+      addLevel = function(x) {
+        print('User::addLevel')
+        level <<- level+x
+      },
+      addHighLevel = function(){
+        print('User::addHighLevel')
+        addLevel(2)
+      }
+    )
+)

定义子类Member,继承父类User,并包括同名方法addLevel覆盖父类的方法,在addLevel方法中,会调用父类的同名方法。


# 子类Member
> Member<-setRefClass("Member",contains="User",
+
+    # 子类中的属性
+    fields=list(age='numeric'),
+    methods=list(
+
+      # 覆盖父类的同名方法
+      addLevel = function(x) {
+          print('Member::addLevel')
+
+          # 调用父类的同名方法
+          callSuper(x)
+          level <<- level+1
+      }
+    )
+)

分别实例化对象u1,m1。


# 实例化u1
> u1<-User$new(name='u1',level=10)
[1] "User::initialize"

# 查看u1对象,$new()不能实现赋值的操作
> u1
Reference class object of class "User"
Field "name":
[1] "conan"
Field "level":
[1] 1

# 通过$initFields()向属性赋值
> u1$initFields(name='u1',level=10)
Reference class object of class "User"
Field "name":
[1] "u1"
Field "level":
[1] 10

# 实例化m1
> m1<-Member$new()
[1] "User::initialize"

> m1$initFields(name='m1',level=100,age=12)
Reference class object of class "Member"
Field "name":
[1] "m1"
Field "level":
[1] 100
Field "age":
[1] 12

执行$copy()方法,复制对象属性并传值。


# 属性复制到u2
> u2<-u1$copy()
[1] "User::initialize"

# 执行方法addLevel(),让level加1,u1已改变
> u1$addLevel(1);u1
[1] "User::addLevel"
Reference class object of class "User"
Field "name":
[1] "u1"
Field "level":
[1] 11

# u2的level与u1没有引入关系,u2没有变化
> u2
Reference class object of class "User"
Field "name":
[1] "u1"
Field "level":
[1] 10

使用方法field(),查看并给level属性赋值。


# 查看level属性值
> u1$field('level')
[1] 11

# 给level赋值为1
> u1$field('level',1)

# 查看level属性值
> u1$level
[1] 1

使用getRefClass()和getClass()方法查看u1对象的类定义。


# 类引入的定义
> m1$getRefClass()
Generator for class "Member":

Class fields:
Name:       name     level       age
Class: character   numeric   numeric

Class Methods:
"addHighLevel", "addLevel", "addLevel#User", "callSuper", "copy", "export", "field", "getClass", "getRefClass", "import", "initFields",
"initialize", "show", "trace", "untrace", "usingMethods"

Reference Superclasses:
"User", "envRefClass"

# 类定义
> m1$getClass()
Reference Class "Member":

Class fields:
Name:       name     level       age
Class: character   numeric   numeric

Class Methods:
"addHighLevel", "addLevel", "addLevel#User", "callSuper", "copy", "export", "field", "getClass", "getRefClass", "import", "initFields",
"initialize", "show", "trace", "untrace", "usingMethods"

Reference Superclasses:
"User", "envRefClass"

# 通过otype查看类型的不同
> otype(m1$getRefClass())
[1] "RC"
> otype(m1$getClass())
[1] "S4"

使用$show()方法查看对象属性值,$show(),同show()函数,对象直接输出时就是调用了$show()方法。


> m1$show()
Reference class object of class "Member"
Field "name":
[1] "m1"
Field "level":
[1] 100
Field "age":
[1] 12

> show(m1)
Reference class object of class "Member"
Field "name":
[1] "m1"
Field "level":
[1] 100
Field "age":
[1] 12

> m1
Reference class object of class "Member"
Field "name":
[1] "m1"
Field "level":
[1] 100
Field "age":
[1] 12

使用 $trace()跟踪方法调用 ,再用 $untrace()方法取消跟踪绑定。


# 对addLevel()方法跟踪
> m1$trace("addLevel")
Tracing reference method "addLevel" for object from class "Member"
[1] "addLevel"

# 调用addLevel()方法,Tracing m1$addLevel(1)被打印,跟踪生效
> m1$addLevel(1)
Tracing m1$addLevel(1) on entry
[1] "Member::addLevel"
[1] "User::addLevel"

# 调用父类的addHighLevel()方法,Tracing addLevel(2)被打印,跟踪生效
> m1$addHighLevel()
[1] "User::addHighLevel"
Tracing addLevel(2) on entry
[1] "Member::addLevel"
[1] "User::addLevel"

# 取消对addLevel()方法跟踪
> m1$untrace("addLevel")
Untracing reference method "addLevel" for object from class "Member"
[1] "addLevel"

使用$export()方法,以类为作用域查看属性值。


# 查看在Member类中的属性
> m1$export('Member')
Reference class object of class "Member"
Field "name":
[1] "m1"
Field "level":
[1] 105
Field "age":
[1] 12

# 查看在User类中的属性,当前作用域不包括age属性。
> m1$export('User')
[1] "User::initialize"
Reference class object of class "User"
Field "name":
[1] "m1"
Field "level":
[1] 105

使用$import()方法,把一个对象的属性值赋值给另一个对象。


# 实例化m2
> m2<-Member$new()
[1] "User::initialize"
> m2
Reference class object of class "Member"
Field "name":
[1] "conan"
Field "level":
[1] 1
Field "age":
numeric(0)

# 把m1对象的值赋值给m2对象
> m2$import(m1)
> m2
Reference class object of class "Member"
Field "name":
[1] "m1"
Field "level":
[1] 105
Field "age":
[1] 12

5.2 内置属性:

RC对象实例化后,有两个内置属性:

  • .self 实例化对象自身
  • .refClassDef 类的定义类型

# $.self属性
> m1$.self
Reference class object of class "Member"
Field "name":
[1] "m1"
Field "level":
[1] 105
Field "age":
[1] 12

#  m1$.self和m1 完全相同
> identical(m1$.self,m1)
[1] TRUE

# 查看类型
> otype(m1$.self)
[1] "RC"


# $.refClassDef属性
> m1$.refClassDef
Reference Class "Member":

Class fields:
Name:       name     level       age
Class: character   numeric   numeric

Class Methods:
"addHighLevel", "addLevel", "addLevel#User", "callSuper", "copy", "export", "field", "getClass", "getRefClass", "import", "initFields",
"initialize", "show", "trace", "untrace", "usingMethods"

Reference Superclasses:
"User", "envRefClass"

# 与$getClass()相同
> identical(m1$.refClassDef,m1$getClass())
[1] TRUE

# 查看类型
> otype(m1$.refClassDef)
[1] "S4"

6 RC类的辅助函数

当定义好了RC的类结构,有一些辅助函数可以帮助我们查看类型的属性和方法,上面用于创建实例化的对象的$new()函数,也属性这类辅助函数。

  • new 用于实例化对象。
  • help 用于查询类中方法的调用。
  • methods 列出类中定义的所有方法。
  • fields 列出类中定义的所有属性。
  • lock 给属性加锁,实例化对象的属性只允许赋值一次,即赋值变量,不可修改。
  • trace 跟踪方法。
  • accessors 给属性生成get/set方法。

接下来,我们使用辅助函数,继续使用我们之前定义的User的类的结构。


# 定义User类
> User<-setRefClass("User",
+    fields=list(name="character",level='numeric'),
+    methods=list(
+      initialize = function(name,level){
+        print("User::initialize")
+        name <<- 'conan'
+        level <<- 1
+      },
+      addLevel = function(x) {
+        print('User::addLevel')
+        level <<- level+x
+      },
+      addHighLevel = function(){
+        print('User::addHighLevel')
+        addLevel(2)
+      }
+    )
+)

# 实例化对象u1
> u1<-User$new()

# 列出User类中的属性
> User$fields()
       name       level
"character"   "numeric"

# 列出User类中的方法
> User$methods()
 [1] "addHighLevel" "addLevel"     "callSuper"
 [4] "copy"         "export"       "field"
 [7] "getClass"     "getRefClass"  "import"
[10] "initFields"   "initialize"   "show"
[13] "trace"        "untrace"      "usingMethods"

# 查看User类的方法调用
> User$help("addLevel")
Call:
$addLevel(x)

> User$help("show")
Call:
$show()

给User类中的属性,增加get/set方法


# 给level属性增加get/set方法
> User$accessors("level")

# 给name属性增加get/set方法
> User$accessors("name")

# 列出所有方法
> User$methods()
 [1] "addHighLevel" "addLevel"     "callSuper"
 [4] "copy"         "export"       "field"
 [7] "getClass"     "getLevel"     "getName"
[10] "getRefClass"  "import"       "initFields"
[13] "initialize"   "setLevel"     "setName"
[16] "show"         "trace"        "untrace"
[19] "usingMethods"

使用$trace()函数,跟踪addLevel方法


# 跟踪User类的addLevel方法
> User$trace('addLevel')
Tracing reference method "addLevel" for class
"User"
[1] "addLevel"

# 实例化对象u3
> u3<-User$new(name='u3',level=1)
[1] "User::initialize"

# addLevel方法调用,出发跟踪日志 Tracing u3$addLevel(2)
> u3$addLevel(2)
Tracing u3$addLevel(2) on entry
[1] "User::addLevel"

使用$lock()函数,把level属性设置为常量。


# 锁定level属性
> User$lock("level")

# 查看User类中被锁定的属性
> User$lock()
[1] "level"

# 实例化对象u3,这时level属性已经被赋值一次
> u3<-User$new()
[1] "User::initialize"
> u3
Reference class object of class "User"
Field "name":
[1] "conan"
Field "level":
[1] 1

# 给level属性,再次赋值出错
> u3$level=1
Error: invalid replacement: reference class field ‘level’ is read-only
> u3$addLevel(2)
[1] "User::addLevel"
Error: invalid replacement: reference class field ‘level’ is read-only

7 RC对象系统的使用

我们接下用RC对象系统做一个例子,定义一套动物叫声研究模型。

7.1 任务一:定义动物的数据结构和发声方法。

假设最Animal为动物的基类,包括 研究的动物包括 猫(cat)、狗(dog)、鸭(duck)。

  • 定义动物的数据结构
  • 分别定义3种动物的发声bark()方法

如图所示结构:

animal

定义动物的数据结构,包括基类的结构 和 3种动物的结构。


# 创建Animal类,包括name属性,构造方法initialize(),叫声方法bark()。
> Animal<-setRefClass("Animal",
+  fields=list(name="character"),
+  methods=list(
+    initialize = function(name) name <<- 'Animal',
+    bark = function() print("Animal::bark")
+  )
+)

# 创建Cat类,继承Animal类,并重写(Overwrite)了 initialize() 和 bark()。
> Cat<-setRefClass("Cat",contains="Animal",
+  methods=list(
+    initialize = function(name) name <<- 'cat',
+    bark = function() print(paste(name,"is miao miao"))
+  )
+)

# 创建Dog类,继承Animal类,并重写(Overwrite)了 initialize() 和 bark()。
> Dog<-setRefClass("Dog",contains="Animal",
+  methods=list(
+    initialize = function(name) name <<- 'dog',
+    bark = function() print(paste(name,"is wang wang"))
+  )
+)

# 创建Duck类,继承Animal类,并重写(Overwrite)了 initialize() 和 bark()。
> Duck<-setRefClass("Duck",contains="Animal",
+   methods=list(
+     initialize = function(name) name <<- 'duck',
+     bark = function() print(paste(name,"is ga ga"))
+   )
+)

接下来,我们实例化对象,然后研究它们的叫声。


# 创建cat实例
> cat<-Cat$new()
> cat$name
[1] "cat"

# cat叫声
> cat$bark()
[1] "cat is miao miao"

# 创建dog实例,并给dog起名叫Huang
> dog<-Dog$new()
> dog$initFields(name='Huang')
Reference class object of class "Dog"
Field "name":
[1] "Huang"
> dog$name
[1] "Huang"

# dog叫声
> dog$bark()
[1] "Huang is wang wang"

# 创建duck实例
> duck<-Duck$new()

# duck叫声
> duck$bark()
[1] "duck is ga ga"

7.2 任务二:定义动物的体貌特征

动物的体貌特征,包括 头、身体、肢、翅等,我在这里只定义肢和翅的特征。

3种动物都有肢,cat和dog是四肢,duck是二肢和二翅。

如图所示结构:

animal2

我们需要对原结构进行修改。


# 定义Animal类,增加limbs属性,默认值为4
Animal<-setRefClass("Animal",
    fields=list(name="character",limbs='numeric'),
    methods=list(
      initialize = function(name) {
          name <<- 'Animal'
          limbs<<-4
      },
      bark = function() print("Animal::bark")
    )
)

# 在Cat类的 initialize()方法中,执行callSuper()方法,调用父类的同名方法
Cat<-setRefClass("Cat",contains="Animal",
     methods=list(
       initialize = function(name) {
         callSuper()
         name <<- 'cat'
       },
       bark = function() print(paste(name,"is miao miao"))
     )
)

# 在Dog类的 initialize()方法中,执行callSuper()方法,调用父类的同名方法
Dog<-setRefClass("Dog",contains="Animal",
     methods=list(
       initialize = function(name) {
         callSuper()
         name <<- 'dog'
       },
       bark = function() print(paste(name,"is wang wang"))
     )
)

# 在Dog类的定义wing属性, 并在initialize()方法,定义limbs和wing属性的默认值
Duck<-setRefClass("Duck",contains="Animal",
    fields=list(wing='numeric'),
    methods=list(
      initialize = function(name) {
          name <<- 'duck'
          limbs<<- 2
          wing<<- 2
      },
      bark = function() print(paste(name,"is ga ga"))
    )
)

实例化对象并查看3种动物的属性值。


# 实例化cat对象,属性limbs为4
> cat<-Cat$new();cat
Reference class object of class "Cat"
Field "name":
[1] "cat"
Field "limbs":
[1] 4

# 实例化dog对象,属性limbs为4
> dog<-Dog$new()
> dog$initFields(name='Huang')
Reference class object of class "Dog"
Field "name":
[1] "Huang"
Field "limbs":
[1] 4
> dog
Reference class object of class "Dog"
Field "name":
[1] "Huang"
Field "limbs":
[1] 4

# 实例化duck对象,属性limbs为2,wing为2
> duck<-Duck$new();duck
Reference class object of class "Duck"
Field "name":
[1] "duck"
Field "limbs":
[1] 2
Field "wing":
[1] 2

7.3 任务三:定义动物的行动方式。

对于 猫(cat),狗(dog),鸭(duck) 来说,它们都可以在陆地上行动,而且还有各自不同的行动方式。

特有行动方式:

  • 猫(cat) 爬树
  • 狗(dog) 游泳
  • 鸭(duck) 游泳,短距离飞行

如图所示结构:

animal3

接下来,我们按动物的不同行动方式进行建模。


# 定义类Animal,增加action()方法,用于通用的行为陆地上行动。
> Animal<-setRefClass("Animal",
+    fields=list(name="character",limbs='numeric'),
+    methods=list(
+      initialize = function(name) {
+        name <<- 'Animal'
+        limbs<<-4
+      },
+      bark = function() print("Animal::bark"),
+      action = function() print("I can walk on the foot")
+    )
+)

# 定义Cat类,重写action()方法,并增加爬树的行动
> Cat<-setRefClass("Cat",contains="Animal",
+     methods=list(
+       initialize = function(name) {
+         callSuper()
+         name <<- 'cat'
+       },
+       bark = function() print(paste(name,"is miao miao")),
+       action = function() {
+         callSuper()
+         print("I can Climb a tree")
+       }
+     )
+  )

# 定义Dog类,重写action()方法,并增加游泳行动
> Dog<-setRefClass("Dog",contains="Animal",
+   methods=list(
+     initialize = function(name) {
+       callSuper()
+       name <<- 'dog'
+     },
+     bark = function() print(paste(name,"is wang wang")),
+     action = function() {
+         callSuper()
+         print("I can Swim.")
+     }
+   )
+)

# 定义Duck类,重写action()方法,并增加游泳和短距离飞行
> Duck<-setRefClass("Duck",contains="Animal",
+    fields=list(wing='numeric'),
+    methods=list(
+      initialize = function(name) {
+        name <<- 'duck'
+        limbs<<- 2
+        wing<<- 2
+      },
+      bark = function() print(paste(name,"is ga ga")),
+      action = function() {
+        callSuper()
+        print("I can swim.")
+        print("I also can fly a short way.")
+     }
+    )
+)

实例化对象,并运行action()方法。

cat的行动。


# 实例化cat
> cat<-Cat$new()

# cat的行动
> cat$action()
[1] "I can walk on the foot"
[1] "I can Climb a tree"

dog的行动。


> dog<-Dog$new()
> dog$action()
[1] "I can walk on the foot"
[1] "I can Swim."

duck的行动。


> duck<-Duck$new()
> duck$action()
[1] "I can walk on the foot"
[1] "I can swim."
[1] "I also can fly a short way."

通过这个例子,我们应该就能全面地了解了R语言中基于RC对象系统的面向对象程序设计了!RC对象系统提供了完全的面向对象的实现。

转载请注明出处:
http://blog.fens.me/r-class-rc/

打赏作者

R语言基于S4的面向对象编程

R的极客理想系列文章,涵盖了R的思想,使用,工具,创新等的一系列要点,以我个人的学习和体验去诠释R的强大。

R语言作为统计学一门语言,一直在小众领域闪耀着光芒。直到大数据的爆发,R语言变成了一门炙手可热的数据分析的利器。随着越来越多的工程背景的人的加入,R语言的社区在迅速扩大成长。现在已不仅仅是统计领域,教育,银行,电商,互联网….都在使用R语言。

要成为有理想的极客,我们不能停留在语法上,要掌握牢固的数学,概率,统计知识,同时还要有创新精神,把R语言发挥到各个领域。让我们一起动起来吧,开始R的极客理想。

关于作者:

  • 张丹(Conan), 程序员Java,R,PHP,Javascript
  • weibo:@Conan_Z
  • blog: http://blog.fens.me
  • email: bsspirit@gmail.com

转载请注明出处:
http://blog.fens.me/r-class-s4/

r-class-s4

前言

本文接上一篇文章 R语言基于S3的面向对象编程,本文继续介绍R语言基于S4的面向对象编程。

S4对象系统具有明显的结构化特征,更适合面向对象的程序设计。Bioconductor社区,以S4对象系统做为基础架构,只接受符合S4定义的R包。

目录

  1. S4对象介绍
  2. 创建S4对象
  3. 访问对象的属性
  4. S4的泛型函数
  5. 查看S4对象的函数
  6. S4对象的使用

1 S4对象介绍

S4对象系统是一种标准的R语言面向对象实现方式,S4对象有明确的类定义,参数定义,参数检查,继承关系,实例化等的面向对象系统的特征。

2 创建S4对象

本文的系统环境

  • Linux: Ubuntu Server 12.04.2 LTS 64bit
  • R: 3.0.1 x86_64-pc-linux-gnu

为了方便我们检查对象的类型,引入pryr包作为辅助工具。关于pryr包的介绍,请参考文章:[撬动R内核的高级工具包pryr](http://blog.fens.me/r-pryr/)


# 加载pryr包
> library(pryr)

2.1 如何创建S4对象?

由于S4对象是标准的面向对象实现方式, 有专门的类定义函数 setClass() 和类的实例化函数new() ,我们看一下setClass()和new()是如何动作的。

2.1.1 setClass()

查看setClass的函数定义


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

参数列表:

  • Class: 定义类名
  • slots: 定义属性和属性类型
  • prototype: 定义属性的默认值
  • contains=character(): 定义父类,继承关系
  • validity: 定义属性的类型检查
  • where: 定义存储空间
  • sealed: 如果设置TRUE,则同名类不能被再次定义
  • package: 定义所属的包
  • S3methods: R3.0.0以后不建议使用
  • representation R3.0.0以后不建议使用
  • access R3.0.0以后不建议使用
  • version R3.0.0以后不建议使用

2.2 创建一个S4对象实例


# 定义一个S4对象
> setClass("Person",slots=list(name="character",age="numeric"))

# 实例化一个Person对象
> father<-new("Person",name="F",age=44)

# 查看father对象,有两个属性name和age
> father
An object of class "Person"
Slot "name":
[1] "F"

Slot "age":
[1] 44

# 查看father对象类型,为Person
> class(father)
[1] "Person"
attr(,"package")
[1] ".GlobalEnv"

# 查看father对象为S4的对象
> otype(father)
[1] "S4"

2.3 创建一个有继承关系的S4对象


# 创建一个S4对象Person
> setClass("Person",slots=list(name="character",age="numeric"))

# 创建Person的子类
> setClass("Son",slots=list(father="Person",mother="Person"),contains="Person")

# 实例化Person对象
> father<-new("Person",name="F",age=44)
> mother<-new("Person",name="M",age=39)

# 实例化一个Son对象
> son<-new("Son",name="S",age=16,father=father,mother=mother)

# 查看son对象的name属性
> son@name
[1] "S"

# 查看son对象的age属性
> son@age
[1] 16

# 查看son对象的father属性
> son@father
An object of class "Person"
Slot "name":
[1] "F"

Slot "age":
[1] 44

# 查看son对象的mother属性
> slot(son,"mother")
An object of class "Person"
Slot "name":
[1] "M"

Slot "age":
[1] 39

# 检查son类型
> otype(son)
[1] "S4"

# 检查son@name属性类型
> otype(son@name)
[1] "primitive"

# 检查son@mother属性类型
> otype(son@mother)
[1] "S4"

# 用isS4(),检查S4对象的类型
> isS4(son)
[1] TRUE
> isS4(son@name)
[1] FALSE
> isS4(son@mother)
[1] TRUE

2.4 S4对象的默认值


> setClass("Person",slots=list(name="character",age="numeric"))

# 属性age为空
> a<-new("Person",name="a")
> a
An object of class "Person"
Slot "name":
[1] "a"

Slot "age":
numeric(0)

# 设置属性age的默认值20
> setClass("Person",slots=list(name="character",age="numeric"),prototype = list(age = 20))

# 属性age为空
> b<-new("Person",name="b")

# 属性age的默认值是20
> b
An object of class "Person"
Slot "name":
[1] "b"

Slot "age":
[1] 20

2.5 S4对象的类型检查


> setClass("Person",slots=list(name="character",age="numeric"))

# 传入错误的age类型
> bad<-new("Person",name="bad",age="abc")
Error in validObject(.Object) :
  invalid class “Person” object: invalid object for slot "age" in class "Person": got class "character", should be or extend class "numeric"

# 设置age的非负检查
> setValidity("Person",function(object) {
+     if (object@age <= 0) stop("Age is negative.")
+ })
Class "Person" [in ".GlobalEnv"]

Slots:
Name:       name       age
Class: character   numeric

# 修传入小于0的年龄
> bad2<-new("Person",name="bad",age=-1)
Error in validityMethod(object) : Age is negative.

2.6 从一个已经实例化的对象中创建新对象

S4对象,还支持从一个已经实例化的对象中创建新对象,创建时可以覆盖旧对象的值


> setClass("Person",slots=list(name="character",age="numeric"))

# 创建一个对象实例n1
> n1<-new("Person",name="n1",age=19);n1
An object of class "Person"
Slot "name":
[1] "n1"

Slot "age":
[1] 19

# 从实例n1中,创建实例n2,并修改name的属性值
> n2<-initialize(n1,name="n2");n2
An object of class "Person"
Slot "name":
[1] "n2"

Slot "age":
[1] 19

3 访问对象的属性

在S3对象中,一般我使用$来访问一个对象的属性,但在S4对象中,我们只能使用@来访问一个对象的属性


> setClass("Person",slots=list(name="character",age="numeric"))
> a<-new("Person",name="a")

# 访问S4对象的属性
> a@name
[1] "a"
> slot(a, "name")
[1] "a"

# 错误的属性访问
> a$name
Error in a$name : $ operator not defined for this S4 class
> a[1]
Error in a[1] : object of type 'S4' is not subsettable
> a[[1]]
Error in a[[1]] : this S4 class is not subsettable

4 S4的泛型函数

S4的泛型函数实现有别于S3的实现,S4分离了方法的定义和实现,如在其他语言中我们常说的接口和实现分离。通过setGeneric()来定义接口,通过setMethod()来定义现实类。这样可以让S4对象系统,更符合面向对象的特征。

普通函数的定义和调用


> work<-function(x) cat(x, "is working")
> work('Conan')
Conan is working

让我来看看如何用R分离接口和现实


# 定义Person对象
> setClass("Person",slots=list(name="character",age="numeric"))

# 定义泛型函数work,即接口
> setGeneric("work",function(object) standardGeneric("work"))
[1] "work"

# 定义work的现实,并指定参数类型为Person对象
> setMethod("work", signature(object = "Person"), function(object) cat(object@name , "is working") )
[1] "work"

# 创建一个Person对象a
> a<-new("Person",name="Conan",age=16)

# 把对象a传入work函数
> work(a)
Conan is working

通过S4对象系统,把原来的函数定义和调用2步,为成了4步进行:

  • 定义数据对象类型
  • 定义接口函数
  • 定义实现函数
  • 把数据对象以参数传入到接口函数,执行实现函数

通过S4对象系统,是一个结构化的,完整的面向对象实现。

5 查看S4对象的函数

当我们使用S4对象进行面向对象封装后,我们还需要能查看到S4对象的定义和函数定义。

还以上节中Person和work的例子


# 检查work的类型
> ftype(work)
[1] "s4"      "generic"

# 直接查看work函数
> work
standardGeneric for "work" defined from package ".GlobalEnv"
function (object)
standardGeneric("work")
<environment: 0x2aa6b18>
Methods may be defined for arguments: object
Use  showMethods("work")  for currently available ones.

# 查看work函数的现实定义
> showMethods(work)
Function: work (package .GlobalEnv)
object="Person"

# 查看Person对象的work函数现实
> getMethod("work", "Person")
Method Definition:
function (object)
cat(object@name, "is working")
Signatures:
        object
target  "Person"
defined "Person"

> selectMethod("work", "Person")
Method Definition:
function (object)
cat(object@name, "is working")
Signatures:
        object
target  "Person"
defined "Person"

# 检查Person对象有没有work函数
>  existsMethod("work", "Person")
[1] TRUE
> hasMethod("work", "Person")
[1] TRUE

6 S4对象的使用

我们接下用S4对象做一个例子,定义一组图形函数的库。

6.1 任务一:定义图形库的数据结构和计算函数

假设最Shape为图形的基类,包括圆形(Circle)和椭圆形(Ellipse),并计算出它们的面积(area)和周长(circum)。

  • 定义图形库的数据结构
  • 定义圆形的数据结构,并计算面积和周长
  • 定义椭圆形的数据结构,并计算面积和周长

如图所示结构:

s4-shape1

定义基类Shape 和 圆形类Circle


# 定义基类Shape
> setClass("Shape",slots=list(name="character"))

# 定义圆形类Circle,继承Shape,属性radius默认值为1
> setClass("Circle",contains="Shape",slots=list(radius="numeric"),prototype=list(radius = 1))

# 验证radius属性值要大等于0
> setValidity("Circle",function(object) {
+     if (object@radius <= 0) stop("Radius is negative.")
+ })
Class "Circle" [in ".GlobalEnv"]
Slots:
Name:     radius      name
Class:   numeric character
Extends: "Shape"

# 创建两个圆形实例
> c1<-new("Circle",name="c1")
> c2<-new("Circle",name="c2",radius=5)

定义计算面积的接口和现实


# 计算面积泛型函数接口
> setGeneric("area",function(obj,...) standardGeneric("area"))
[1] "area"

# 计算面积的函数现实
> setMethod("area","Circle",function(obj,...){
+     print("Area Circle Method")
+     pi*obj@radius^2
+ })
[1] "area"

# 分别计算c1和c2的两个圆形的面积
> area(c1)
[1] "Area Circle Method"
[1] 3.141593
> area(c2)
[1] "Area Circle Method"
[1] 78.53982

定义计算周长的接口和现实


# 计算周长泛型函数接口
> setGeneric("circum",function(obj,...) standardGeneric("circum"))
[1] "circum"

# 计算周长的函数现实
> setMethod("circum","Circle",function(obj,...){
+     2*pi*obj@radius
+ })

# 分别计算c1和c2的两个圆形的面积
[1] "circum"
> circum(c1)
[1] 6.283185
> circum(c2)
[1] 31.41593

上面的代码,我们实现了圆形的定义,下来我们实现椭圆形。


# 定义椭圆形的类,继承Shape,radius参数默认值为c(1,1),分别表示椭圆形的长半径和短半径
> setClass("Ellipse",contains="Shape",slots=list(radius="numeric"),prototype=list(radius=c(1,1)))

# 验证radius参数
> setValidity("Ellipse",function(object) {
+     if (length(object@radius) != 2 ) stop("It's not Ellipse.")
+     if (length(which(object@radius<=0))>0) stop("Radius is negative.")
+ })
Class "Ellipse" [in ".GlobalEnv"]
Slots:
Name:     radius      name
Class:   numeric character
Extends: "Shape"

# 创建两个椭圆形实例e1,e2
> e1<-new("Ellipse",name="e1")
> e2<-new("Ellipse",name="e2",radius=c(5,1))

# 计算椭圆形面积的函数现实
> setMethod("area", "Ellipse",function(obj,...){
+     print("Area Ellipse Method")
+     pi * prod(obj@radius)
+ })
[1] "area"

# 计算e1,e2两个椭圆形的面积
> area(e1)
[1] "Area Ellipse Method"
[1] 3.141593
> area(e2)
[1] "Area Ellipse Method"
[1] 15.70796

# 计算椭圆形周长的函数现实
> setMethod("circum","Ellipse",function(obj,...){
+     cat("Ellipse Circum :\n")
+     2*pi*sqrt((obj@radius[1]^2+obj@radius[2]^2)/2)
+ })
[1] "circum"

# 计算e1,e2两个椭圆形的周长
> circum(e1)
Ellipse Circum :
[1] 6.283185
> circum(e2)
Ellipse Circum :
[1] 22.65435

6.2 任务二:重构圆形和椭圆形的设计

上一步,我们已经完成了 圆形和椭圆形 的数据结构定义,以及计算面积和周长的方法现实。不知大家有没有发现,圆形是椭圆形的一个特例呢?

当椭圆形的长半径和短半径相等时,即radius的两个值相等,形成的图形为圆形。利用这个特点,我们就可以重新设计 圆形和椭圆形 的关系。椭圆形是圆形的父类,而圆形是椭圆形的子类。

如图所示结构:

s4-shape2


# 基类Shape
> setClass("Shape",slots=list(name="character",shape="character"))

# Ellipse继承Shape
> setClass("Ellipse",contains="Shape",slots=list(radius="numeric"),prototype=list(radius=c(1,1),shape="Ellipse"))

# Circle继承Ellipse
> setClass("Circle",contains="Ellipse",slots=list(radius="numeric"),prototype=list(radius = 1,shape="Circle"))

# 定义area接口
> setGeneric("area",function(obj,...) standardGeneric("area"))
[1] "area"

# 定义area的Ellipse实现
> setMethod("area","Ellipse",function(obj,...){
+     cat("Ellipse Area :\n")
+     pi * prod(obj@radius)
+ })
[1] "area"

# 定义area的Circle实现
> setMethod("area","Circle",function(obj,...){
+     cat("Circle Area :\n")
+     pi*obj@radius^2
+ })
[1] "area"

# 定义circum接口
> setGeneric("circum",function(obj,...) standardGeneric("circum"))
[1] "circum"

# 定义circum的Ellipse实现
> setMethod("circum","Ellipse",function(obj,...){
+     cat("Ellipse Circum :\n")
+     2*pi*sqrt((obj@radius[1]^2+obj@radius[2]^2)/2)
+ })
[1] "circum"

# 定义circum的Circle实现
> setMethod("circum","Circle",function(obj,...){
+     cat("Circle Circum :\n")
+     2*pi*obj@radius
+ })
[1] "circum"

# 创建实例
> e1<-new("Ellipse",name="e1",radius=c(2,5))
> c1<-new("Circle",name="c1",radius=2)

# 计算椭圆形的面积和周长
> area(e1)
Ellipse Area :
[1] 31.41593
> circum(e1)
Ellipse Circum :
[1] 23.92566

# 计算圆形的面积和周长
> area(c1)
Circle Area :
[1] 12.56637
> circum(c1)
Circle Circum :
[1] 12.56637

我们重构后的结构,是不是会更合理呢!!

6.3 任务三:增加矩形的图形处理

我们的图形库,进一步扩充,需要加入矩形和正方形。

  • 定义矩形的数据结构,并计算面积和周长
  • 定义正方形的数据结构,并计算面积和周长
  • 正方形是矩形的特例,定义矩形是正方形的父类,而正方形是矩形的子类。

如图所示结构:

s4-shape3


# 定义矩形Rectangle,继承Shape
> setClass("Rectangle",contains="Shape",slots=list(edges="numeric"),prototype=list(edges=c(1,1),shape="Rectangle"))

# 定义正方形Square,继承Rectangle
> setClass("Square",contains="Rectangle",slots=list(edges="numeric"),prototype=list(edges=1,shape="Square"))

# 定义area的Rectangle实现
> setMethod("area","Rectangle",function(obj,...){
+     cat("Rectangle Area :\n")
+     prod(obj@edges)
+ })
[1] "area"

# 定义area的Square实现
> setMethod("area","Square",function(obj,...){
+     cat("Square Area :\n")
+     obj@edges^2
+ })
[1] "area"

# 定义circum的Rectangle实现
> setMethod("circum","Rectangle",function(obj,...){
+     cat("Rectangle Circum :\n")
+     2*sum(obj@edges)
+ })
[1] "circum"

# 定义circum的Square实现
> setMethod("circum","Square",function(obj,...){
+     cat("Square Circum :\n")
+     4*obj@edges
+ })
[1] "circum"

# 创建实例
> r1<-new("Rectangle",name="r1",edges=c(2,5))
> s1<-new("Square",name="s1",edges=2)

# 计算矩形形的面积和周长
> area(r1)
Rectangle Area :
[1] 10
> area(s1)
Square Area :
[1] 4

# 计算正方形的面积和周长
> circum(r1)
Rectangle Circum :
[1] 14
> circum(s1)
Square Circum :
[1] 8

这样,我们的图形库,已经支持了4种图形了!用面向对象的结构来设计,是不是结构化思路很清晰呢!!

6.4 任务四:在基类Shape中,增加shape属性和getShape方法

接下来,要对图形库的所有图形,定义图形类型的变量shape,然后再提供一个getShape函数可以检查实例中的是shape变量。

这个需求,如果没有面向对象的结构,那么你需要在所有图形定义的代码中,都增加一个参数和一个判断,如果有100图形,改起来还是挺复杂的。而面向对象的程序设计,就非常容易解决这个需求。我们只需要在基类上改动代码就可以实现了。

如图所示结构:

s4-shape4


# 重新定义基类Shape,增加shape属性
> setClass("Shape",slots=list(name="character",shape="character"))

# 定义getShape接口
> setGeneric("getShape",function(obj,...) standardGeneric("getShape"))
[1] "getShape"

# 定义getShape实现
> setMethod("getShape","Shape",function(obj,...){
+     cat(obj@shape,"\n")
+ })
[1] "getShape"

其实,这样改动一个就可以了,我们只需要重实例化每个图形的对象就行了。


# 实例化一个Square对象,并给shape属性赋值
> s1<-new("Square",name="s1",edges=2, shape="Square")

# 调用基类的getShape()函数
> getShape(r1)
Rectangle

是不是很容易的呢!在代码只在基类里修改了,所有的图形就有了对应的属性和方法。

如果我们再多做一步,可以修改每个对象的定义,增加shape属性的默认值。


setClass("Ellipse",contains="Shape",slots=list(radius="numeric"),prototype=list(radius=c(1,1),shape="Ellipse"))
setClass("Circle",contains="Ellipse",slots=list(radius="numeric"),prototype=list(radius = 1,shape="Circle"))
setClass("Rectangle",contains="Shape",slots=list(edges="numeric"),prototype=list(edges=c(1,1),shape="Rectangle"))
setClass("Square",contains="Rectangle",slots=list(edges="numeric"),prototype=list(edges=1,shape="Square"))

再实例化对象时,属性shape会被自动赋值


# 实例化一个Square对象
> s1<-new("Square",name="s1",edges=2)

# 调用基类的getShape()函数
> getShape(r1)
Rectangle

下面是完整的R语言的代码实现:


setClass("Shape",slots=list(name="character",shape="character"))
setClass("Ellipse",contains="Shape",slots=list(radius="numeric"),prototype=list(radius=c(1,1),shape="Ellipse"))
setClass("Circle",contains="Ellipse",slots=list(radius="numeric"),prototype=list(radius = 1,shape="Circle"))
setClass("Rectangle",contains="Shape",slots=list(edges="numeric"),prototype=list(edges=c(1,1),shape="Rectangle"))
setClass("Square",contains="Rectangle",slots=list(edges="numeric"),prototype=list(edges=1,shape="Square"))

setGeneric("getShape",function(obj,...) standardGeneric("getShape"))
setMethod("getShape","Shape",function(obj,...){
  cat(obj@shape,"\n")
})


setGeneric("area",function(obj,...) standardGeneric("area"))
setMethod("area","Ellipse",function(obj,...){
  cat("Ellipse Area :\n")
  pi * prod(obj@radius)
})
setMethod("area","Circle",function(obj,...){
  cat("Circle Area :\n")
  pi*obj@radius^2
})
setMethod("area","Rectangle",function(obj,...){
  cat("Rectangle Area :\n")
  prod(obj@edges)
})
setMethod("area","Square",function(obj,...){
  cat("Square Area :\n")
  obj@edges^2
})


setGeneric("circum",function(obj,...) standardGeneric("circum"))
setMethod("circum","Ellipse",function(obj,...){
  cat("Ellipse Circum :\n")
  2*pi*sqrt((obj@radius[1]^2+obj@radius[2]^2)/2)
})
setMethod("circum","Circle",function(obj,...){
  cat("Circle Circum :\n")
  2*pi*obj@radius
})
setMethod("circum","Rectangle",function(obj,...){
  cat("Rectangle Circum :\n")
  2*sum(obj@edges)
})
setMethod("circum","Square",function(obj,...){
  cat("Square Circum :\n")
  4*obj@edges
})

e1<-new("Ellipse",name="e1",radius=c(2,5))
c1<-new("Circle",name="c1",radius=2)

r1<-new("Rectangle",name="r1",edges=c(2,5))
s1<-new("Square",name="s1",edges=2)

area(e1)
area(c1)
circum(e1)
circum(c1)

area(r1)
area(s1)
circum(r1)
circum(s1)

通过这个例子,我们全面地了解了R语言中面向对象的使用,和S4对象系统的面向对象程序设计!

在程序员的世界里,世间万物都可以抽象成对象。

转载请注明出处:
http://blog.fens.me/r-class-s4/

打赏作者

R语言面向对象编程

R的极客理想系列文章,涵盖了R的思想,使用,工具,创新等的一系列要点,以我个人的学习和体验去诠释R的强大。

R语言作为统计学一门语言,一直在小众领域闪耀着光芒。直到大数据的爆发,R语言变成了一门炙手可热的数据分析的利器。随着越来越多的工程背景的人的加入,R语言的社区在迅速扩大成长。现在已不仅仅是统计领域,教育,银行,电商,互联网….都在使用R语言。

要成为有理想的极客,我们不能停留在语法上,要掌握牢固的数学,概率,统计知识,同时还要有创新精神,把R语言发挥到各个领域。让我们一起动起来吧,开始R的极客理想。

关于作者:

  • 张丹(Conan), 程序员Java,R,PHP,Javascript
  • weibo:@Conan_Z
  • blog: http://blog.fens.me
  • email: bsspirit@gmail.com

转载请注明出处:
http://blog.fens.me/r-object-oriented-intro/

R-OO

前言

面向对象是一种对现实世界理解和抽象的方法,当代码复杂度增加难以维护的时候,面向对象就会显得非常重要。我经历过Java和Javascript两种语言从面向过程到面向对象思路的改造,并感觉这种变化也会出现在R语言中。在工业界的引导下,R将走向大规则的企业应用,因此面向对象的编程方式将成为R语言的一种非常重要的发展方向,动起来迎接R的进步。

目录

  1. 什么是面向对象?
  2. R为什么要进行面向对象编程?
  3. R的面向对象编程
  4. 与其他语言的对比

1 什么是面向对象?

面向对象是一种对现实世界理解和抽象的方法,是计算机编程技术发展到一定阶段后的产物。早期的计算机编程是基于面向过程的方法,例如实现算术运算2+3+4=9,通过设计一个算法就可以解决当时的问题。

随着计算机技术的不断提高,计算机被用于解决越来越复杂的问题。一切事物皆对象,通过面向对象的方式,将现实世界的事物抽象成对象,现实世界中的关系抽象成类、继承,帮助人们实现对现实世界的抽象与数字建模。通过面向对象的方法,更利于用人理解的方式对复杂系统进行分析、设计与编程。同时,面向对象能有效提高编程的效率,通过封装技术,消息机制可以像搭积木的一样快速开发出一个全新的系统。面向对象是指一种程序设计范型,同时也是一种程序开发的方法。对象指的是类的集合。它将对象作为程序的基本单元,将程序和数据封装其中,以提高软件的重用性、灵活性和扩展性。

面向对象的3个特征:封装,继承,多态

封装:是把客观事物封装成抽象的类,并且类可以把自己的数据和方法只让可信的类或者对象操作,对不可信的进行信息隐藏。

oo1

我们通过面向对象的思想,定义老师和学生两个对象,并分别定义老师和学生的行为。

  • 老师的行为:讲课,布置作业,批作业
  • 学生的行为:听课,写作业,考试

通过封装就把两个客观事物进行了抽象,并设置了事情的行为。

继承:子类自动共享父类数据结构和方法的机制,这是类之间的一种关系。在定义和实现一个类的时候,可以在一个已经存在的类的基础之上来进行,使用现有类的所有功能,并在无需重新编写原来的类的情况下对这些功能进行扩展。通过继承创建的新类称为“子类”或“派生类”;被继承的类称为“基类”、“父类”或“超类”。

oo2

通常每门课都会从学生中选出这门课的课代表,来帮助老师和其他同学的沟通。课代表会有一些比普通同学更多特权。通过继承关系,把普通同学和课代表区别为两个子类,课代表不仅有普通同学的行为,还有帮助老师批作业的行为。

多态: 指由继承而产生的相关的不同的类,其对象对同一消息会做出不同的响应。

oo3

临近期末考试时,总有考的好的同学和考的不好的同学。所以,对于优等生来说,他的考试结果是优;次等生,考试结果就不是太好。相同行为对于由继承而产生的相关的不同的对象,结果是不同的。

所以,通过面向对象的思想,我们可以把客观世界的事物都进行抽象。

is a 和 has a

在客观世界中有若干类,这些类之间有一定的结构关系。通常有两种主要的结构关系,is a,和 has a。

  • is a: 为继承关系,比如 菱形、圆形和方形都是一种形状
  • has a:为组合关系或聚合关系,比如 电脑是由显示器、CPU、硬盘等组成

2 R为什么要进行面向对象编程?

R主要面向统计计算,而且代码量一般不会很大,几十行,几百行,使用面向过程的编程方法就可以很好地完成编程的任务。

不过,虽然R语言的持续手热,伴随着越来越多的工程背景的人的加入,R语言开始向更多的领域发展。原来的少量的代码的面向过程的编码方式,会越来越难以维护海量代码的项目,所以必须有一种新的编程方式来代码原来的面向过程的编码思路,这种新的编程方式就是面向对象编程(Object Oriented Programming, OOP)。

面向对象编程,早在C++/Java时代就被广泛使用了,几乎90%以上的Java框架都是按面向对象的方法设计的;8年前Javascript各种面向过程编码让前端开发困难重重,直到Google的Gmail的Web端出现,才让大家认识到原来Javascript也可以面向对象编程,随后的jQuery, ExtJS等类库的完全面向对象的实现,终于让Javascript承得起前端的天空,后来的Node的诞生更是让Javascript拓宽了应用领域。

当R语言被大家所看好的同时,我们也要开始思考,如何才能让R成为工业界的开发语言?应用如何构建非统计计算的项目?如何用R有效的编写10万行以上的代码?

我想这个答案就是以面向对象进行编程,现在的R就像8年前的Javascript,需要大公司和牛人来推动。从我的观察来看,以Hadley Wickham为代表的R语言领军人物,已经开始在R包中全面引入面向对象思路进行R包的开发了。以面向对象思想开发的R包memoise,请参考文章:R语言本地缓存memoise

3 R的面向对象编程

R的面向对象编程是基于泛型函数(generic function)的,而不是基于类层次结构。接下来,我从面向对象的3个特征入手,分别用R语言进行实现,使用的案例为上文中,老师和学生的3幅图。

3.1 R语言实现封装


# 定义老师对象和行为
> teacher <- function(x, ...) UseMethod("teacher")
> teacher.lecture <- function(x) print("讲课")
> teacher.assignment <- function(x) print("布置作业")
> teacher.correcting <- function(x) print("批改作业")
> teacher.default<-function(x) print("你不是teacher")

# 定义同学对象和行为
> student <- function(x, ...) UseMethod("student")
> student.attend <- function(x) print("听课")
> student.homework <- function(x) print("写作业")
> student.exam <- function(x) print("考试")
> student.default<-function(x) print("你不是student")

# 定义两个变量,a老师和b同学
> a<-'teacher'
> b<-'student'

# 给老师变量设置行为
> attr(a,'class') <- 'lecture'
# 执行老师的行为
> teacher(a)
[1] "讲课"

# 给同学变量设置行为
> attr(b,'class') <- 'attend'
# 执行同学的行为
> student(b)
[1] "听课"

> attr(a,'class') <- 'assignment'
> teacher(a)
[1] "布置作业"

> attr(b,'class') <- 'homework'
> student(b)
[1] "写作业"
 
> attr(a,'class') <- 'correcting'
> teacher(a)
[1] "批改作业"
 
> attr(b,'class') <- 'exam'
> student(b)
[1] "考试"

# 定义一个变量,既是老师又是同学 
> ab<-'student_teacher'
# 分别设置不同对象的行为
> attr(ab,'class') <- c('lecture','homework')
# 执行老师的行为
> teacher(ab)
[1] "讲课"
# 执行同学的行为
> student(ab)
[1] "写作业"

3.2 R语言实现继承


# 给同学对象增加新的行为
> student.correcting <- function(x) print("帮助老师批改作业")

# 辅助变量用于设置初始值
> char0 = character(0)

# 实现继承关系
> create <- function(classes=char0, parents=char0) {
+     mro <- c(classes)
+     for (name in parents) {
+         mro <- c(mro, name)
+         ancestors <- attr(get(name),'type')
+         mro <- c(mro, ancestors[ancestors != name])
+     }
+     return(mro)
+ }

# 定义构造函数,创建对象
> NewInstance <- function(value=0, classes=char0, parents=char0) {
+     obj <- value
+     attr(obj,'type') <- create(classes, parents)
+     attr(obj,'class') <- c('homework','correcting','exam')
+     return(obj)
+ }

# 创建父对象实例
> StudentObj <- NewInstance()

# 创建子对象实例
> s1 <- NewInstance('普通同学',classes='normal', parents='StudentObj')
> s2 <- NewInstance('课代表',classes='leader', parents='StudentObj')

# 给课代表,增加批改作业的行为
> attr(s2,'class') <- c(attr(s2,'class'),'correcting')

# 查看普通同学的对象实例
> s1
[1] "普通同学"
attr(,"type")
[1] "normal"     "StudentObj"
attr(,"class")
[1] "homework"   "attend" "exam"      

# 查看课代表的对象实例
> s2
[1] "课代表"
attr(,"type")
[1] "leader"     "StudentObj"
attr(,"class")
[1] "homework"   "attend" "exam"       "correcting"

3.3 R语言实现多态


# 创建优等生和次等生,两个实例
> e1 <- NewInstance('优等生',classes='excellent', parents='StudentObj')
> e2 <- NewInstance('次等生',classes='poor', parents='StudentObj')

# 修改同学考试的行为,大于85分结果为优秀,小于70分结果为及格
> student.exam <- function(x,score) {
+     p<-"考试"
+     if(score>85) print(paste(p,"优秀",sep=""))
+     if(score<70) print(paste(p,"及格",sep=""))
+ }

# 执行优等生的考试行为,并输入分数为90
> attr(e1,'class') <- 'exam'
> student(e1,90)
[1] "考试优秀"

# 执行次等生的考试行为,并输入分数为66
> attr(e2,'class') <- 'exam'
> student(e2,66)
[1] "考试及格"

这样通过R语言的泛型函数,我们就实现了面向对象的编程。

4 R的面向过程编程

接下来,我们再次对比用R语言用面向过程实现上面的逻辑。

4.1 定义老师和同学两个对象和行为


# 辅助变量用于设置初始值
> char0 = character(1)

# 定义老师对象和行为
> teacher_fun<-function(x=char0){
+     if(x=='lecture'){
+         print("讲课")
+     }else if(x=='assignment'){
+         print("布置作业")
+     }else if(x=='correcting'){
+         print("批改作业")
+     }else{
+         print("你不是teacher")
+     }
+ }

# 定义同学对象和行为 
> student_fun<-function(x=char0){
+     if(x=='attend'){
+         print("听课")
+     }else if(x=='homework'){
+         print("写作业")
+     }else if(x=='exam'){
+         print("考试")
+     }else{
+         print("你不是student")
+     }
+ }

# 执行老师的一个行为
> teacher_fun('lecture')
[1] "讲课"

# 执行同学的一个行为
> student_fun('attend')
[1] "听课"

4.2 区别普通同学和课代表的行为


# 重定义同学的函数,增加角色判断
> student_fun<-function(x=char0,role=0){
+     if(x=='attend'){
+         print("听课")
+     }else if(x=='homework'){
+         print("写作业")
+     }else if(x=='exam'){
+         print("考试")
+     }else if(x=='correcting'){
+         if(role==1){#课代表
+             print("帮助老师批改作业")  
+         }else{
+             print("你不是课代表")  
+         }
+     }else{
+         print("你不是student")
+     }
+ }

# 以普通同学的角色,执行课代表的行为
> student_fun('correcting')
[1] "你不是课代表"

# 以课代表的角色,执行课代表的行为
> student_fun('correcting',1)
[1] "帮助老师批改作业"

我在修改student_fun()函数的同时,已经增加了原函数的复杂度。

4.3 参加考试,以成绩区别出优等生和次等生


# 修改同学的函数定义,增加考试成绩参数
> student_fun<-function(x=char0,role=0,score){
+     if(x=='attend'){
+         print("听课")
+     }else if(x=='homework'){
+         print("写作业")
+     }else if(x=='exam'){
+         p<-"考试"
+         if(score>85) print(paste(p,"优秀",sep=""))
+         if(score<70) print(paste(p,"及格",sep=""))
+     }else if(x=='correcting'){
+         if(role==1){#课代表
+             print("帮助老师批改作业")  
+         }else{
+             print("你不是课代表")  
+         }
+     }else{
+         print("你不是student")
+     }
+ }

# 执行考试函数,考试成绩为大于85分,为优等生
> student_fun('exam',score=90)
[1] "考试优秀"

# 执行考试函数,考试成绩为小于70分,为次等生
> student_fun('exam',score=66)
[1] "考试及格"

我再一次用面向过程的代码,实现了整个的编辑逻辑。再用到面向过程来写程序的时候,每一次的需求变化,都需要对原始代码进行修改,从而不仅增加了复杂度,而且不利于长久的维护。更多思考留给了大家!

本文抛砖引玉地讲了R语言的面向对象的编程,其中部分代码有些不够严谨,本文只希望给大家思路上的认识,更具体的面向对象编程实例,会在以后的文章中进行讨论。

转载请注明出处:
http://blog.fens.me/r-object-oriented-intro/

打赏作者