• Posts tagged "S4"

Blog Archives

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语言基于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内核的高级工具包pryr

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-pryr/

r-pryr

前言

随着对R语言的使用越来越深入,我们需要更多的对R语言底层的进行了解,比如数据结构S3,S4对象,函数的调用机制等。pryr包就是可以帮助我们了解R语言运行机制的工具。利用pryr包,我们可以更容易地接触R的核心。

本文为R语言的高级内容。

目录

  1. pryr介绍
  2. pryr安装
  3. pryr使用

1 pryr介绍

pryr包是一个深层的了解R语言运行机制的工具,可以帮助我们更加贴近R语言的核心。为了能开发出更高级R语言应用,需要我们更深入地懂R。

pryr的API介绍

内部实现工具:

  • promise对象:uneval(), is_promise()
  • 查询环境变量: where(), rls(), parenv()
  • 查看闭包函数变量: unenclose()
  • 函数调用关系:call_tree()
  • 查看对象底层对应的C语言类型 address(), refs(), typename()
  • 跟踪对象是否被修改track_copy()

面向对象检查:

  • 判断属于哪种类型对象: otype()
  • 判断属于哪种类型函数: ftype()

辅助编程函数:

  • 通过参数创建函数:make_function(), f()
  • 变量表达式替换:substitute_q(), subs()
  • 批量修改对象: modify_lang()
  • 快速创建list对象:dots(), named_dots()
  • 建匿名函数调用:partial()
  • 找符合条件函数:find_funs()

代码简化工具:

  • 创建延迟或直接绑定:%<d-%, %<a-%
  • 创建常量绑定:%<c-%
  • 重新绑定:rebind, <<-

2 pryr安装

系统环境

  • Linux Ubuntu 12.04.2 LTS 64bit
  • R 3.0.1 x86_64-pc-linux-gnu (64-bit)

由于项目pryr,还没有发布到CRAN,仅支持从github安装。我们要使用devtools包来通过github来安装。关于devtools包的使用,请参考文章:在巨人的肩膀前行 催化R包开发

pryr安装


~ R

# 安装devtools
# install.packages("devtools")

> library(devtools)
> install_github("pryr")

注:我尝试在Win7下安装,但出现了编译错误。

3 pryr使用

  • 3.1 创建匿名函数f()
  • 3.2 通过参数创建函数make_function()
  • 3.3 创建匿名函数调用partial()
  • 3.4 变量表达式替换substitute_q(), subs()
  • 3.5 面向对象类型判断otype(),ftype()
  • 3.6 查看对象底层的C语言类型 address(), refs(), typename()
  • 3.7 查看对象是否被修改track_copy()
  • 3.8 查看闭包函数变量 unenclose()
  • 3.9 批量修改对象 modify_lang()
  • 3.10 快速创建list对象 dots(), named_dots()
  • 3.11 查找符合条件函数 fun_calls()
  • 3.12 查询环境变量 where(), rls(), parenv()
  • 3.13 打印函数调用关系 call_tree(), ast()
  • 3.14 promise对象 uneval(), is_promise()
  • 3.15 数据绑定%<a-%, %<c-%,%<d-%, rebind,<<-

3.1 创建匿名函数f()

通过使用f()函数,可以实现创建匿名函数,在单行完成函数定义、调用、运算的操作。


# 创建一个匿名函数
> f(x + y)
function (x, y)
x + y

# 创建一个匿名函数,并赋值计算
> f(x + y)(1, 10)
[1] 11

# 创建一个匿名函数,指定参数和默认值
> f(x, y = 2, x + y)
function (x, y = 2)
x + y

# 创建一个匿名函数,并赋值计算
> f(x, y = 2, x + y)(1)
[1] 3

# 创建一个匿名函数,多行运行,并赋值计算
>  f({y <- runif(1); x + y})(3)
[1] 3.7483

3.2 通过参数创建函数make_function()

通过使用make_function()函数,可以通过make_function()函数的3个参数,来创建一个普通的函数,从而现实动态性。

make_function()函数的3个参数分别是:

  • 生成函数的参数部分, list类型
  • 生成函数的表达式部分, 语法表达式, call类型
  • 生成函数的系统环境部分, environment类型

# 创建标准的函数
> f <- function(x) x + 3
> f
function(x) x + 3

# 运行函数
> f(12)
[1] 15

# 通过参数创建函数
> g <- make_function(alist(x = ), quote(x + 3))
> g
function (x)
x + 3

# 运行函数
> g(12)
[1] 15

3.3 创建匿名函数调用partial()

使用partial()函数,可以减少参数定义的过程,方便匿名函数的调用


# 定义一个普通的函数
> compact1 <- function(x) Filter(Negate(is.null), x)
> compact1
function(x) Filter(Negate(is.null), x)

# 通过partial定义的匿名函数
> compact2 <- partial(Filter, Negate(is.null))
> compact2
function (...)
Filter(Negate(is.null), ...)

我们看到,上面的两个函数定义很像,一个是有明确的参数定义,另一个用partial()则是隐式的参数定义。

再看另一例:输出runif()均匀分布的结果


# 标准函数实现
> f1 <- function(){runif(rpois(1, 5))}
> f1()
[1] 0.09654228 0.93089395 0.85530142 0.33021067 0.16728877 0.79099825
> f1()
[1] 0.6166580 0.2100876 0.3125176

# 通过partial的匿名函数调用
> f2 <- partial(runif, n = rpois(1, 5))
> f2()
[1] 0.25955143 0.12858459 0.04994997 0.11505708 0.10509429
> f2()
[1] 0.9710866 0.1469317

3.4 变量表达式替换 substitute_q(), subs()

使用substitute_q()函数,可以对表达式调用,直接进行参数替换


# 定义一个表达式调用
>  x <- quote(a + b)
> class(x)
[1] "call"

# 对x调用参数替换,无效
>  substitute(x, list(a = 1, b = 2))
x

# 对直接变量参数替换
> substitute(a+b, list(a = 1, b = 2))
1 + 2

# 对x调用参数替换
>  substitute_q(x, list(a = 1, b = 2))
1 + 2

执行参数调用
> eval(substitute_q(x, list(a = 1, b = 2)))
[1] 3

使用subs()函数,可以直接对变量表达式替换


> a <- 1
> b <- 2

# 对变量表达式替换,无效
> substitute(a + b)
a + b

# 对变量表达式替换
> subs(a + b)
1 + 2

3.5 面向对象类型判断otype(),ftype()

判断对象类型:通过otype()函数可以很容易的分辨出基本类型,S3类型,S4类型,RC类型的对象,比起内置的类型检查要高效的多。


# 基本类型
> otype(1:10)
[1] "primitive"
> otype(c('a','d'))
[1] "primitive"
> otype(list(c('a'),data.frame()))
[1] "primitive"

# S3类型
> otype(data.frame())
[1] "S3"

# 自定的S3类型
> x <- 1
> attr(x,'class')<-'foo'
> is.object(x)
[1] TRUE
> otype(x)
[1] "S3"

# S4类型
> setClass("Person",slots=list(name="character",age="numeric"))
> alice<-new("Person",name="Alice",age=40) 
> isS4(alice)
[1] TRUE
> otype(alice)
[1] "S4"

# RC类型
> Account<-setRefClass("Account")
> a<-Account$new()
> class(a)
[1] "Account"
attr(,"package")
[1] ".GlobalEnv"

> is.object(a)
[1] TRUE
> isS4(a)
[1] TRUE
> otype(a)
[1] "RC"

判断函数类型:通过ftype()函数可以很容易的分辨出function,primitive,S3,S4,internal类型的函数,比起内置的类型检查要高效的多。


# 标准函数
> ftype(`%in%`)
[1] "function"

# primitive函数
> ftype(sum)
[1] "primitive" "generic"

# internal函数
> ftype(writeLines)
[1] "internal"
> ftype(unlist)
[1] "internal" "generic"

# S3函数
>  ftype(t.data.frame)
[1] "s3"     "method"
> ftype(t.test)
[1] "s3"      "generic"

# S4 函数
> setGeneric("union")
[1] "union"
> setMethod("union",c(x="data.frame",y="data.frame"),function(x, y){unique(rbind (x, y))})
[1] "union"
> ftype(union)
[1] "s4"      "generic"

# RC函数
> Account<-setRefClass("Account",fields=list(balance="numeric"),methods=list(
+   withdraw=function(x){balance<<-balance-x},
+   deposit=function(x){balance<<-balance+x}))
> a<-Account$new(balance=100)
> a$deposit(100)
> ftype(a$deposit)
[1] "rc"     "method"

3.6 查看对象底层的C语言类型 address(), refs(), typename()

我们可以通过address(), refs(), typename()来查看,R对象对应的底层C语言实现的类型。

  • typename: 返回C语言类型名
  • address: 返回内存地址
  • refs: 返回指针数字

查看变量


# 定义一个变量x
>  x <- 1:10

# 打印C语言类型名
> typename(x)
[1] "INTSXP"

# 返回指针
> refs(x)
[1] 1

# 打印内存地址
> address(x)
[1] "0x365f560"

# 定义一个list对象
>  z <- list(1:10)

# 打印C语言类型名
>  typename(z)
[1] "VECSXP"

# 延迟赋值
> delayedAssign("a", 1 + 2)

# 打印C语言类型名
> typename(a)
[1] "PROMSXP"

# 打印a变量
> a
[1] 3
> typename(a)
[1] "PROMSXP"

# 定义变量b,与a变量对比
> b<-3
> typename(b)
[1] "REALSXP"

3.7 查看对象是否被修改track_copy()

使用track_copy()函数,我们可以跟踪对象,并检查是被修改过,通过内存地址进行判断。


# 定义一个变量
> a<-1:3
> a
[1] 1 2 3

# 查看变量的内存地址
> address(a)
[1] "0x2ad77f0"

# 跟踪变量
> track_a <- track_copy(a)

# 检查变更是否被修改,没有修改
> track_a()

# 给变量赋值
> a[3] <- 3L

# 查看变量的内存地址,发现没有变化
> address(a)
[1] "0x2ad77f0"

# 检查变量是否被修改,没有修改
>  track_a()

# 再次给变量赋值
> a[3]<-3

# 查看变量的内存地址,内存地址改变
> address(a)
[1] "0x37f8580"

# 检查变量是否被修改,已被修改,变成一份copy
>  track_a()
a copied

3.8 查看闭包函数变量 unenclose()

使用unenclose()给闭包环境的变量的赋值


# 定义一个嵌套函数power
>  power <- function(exp) {
+      function(x) x ^ exp
+  }

# 调用闭包函数
>  square <- power(2)
>  cube <- power(3)

# 查看square函数,exp变量并显示没有赋值后的结果
> square
function(x) x ^ exp
<environment: 0x4055f28>

# 查看square函数,exp变量显示赋值后的结果
> unenclose(square)
function (x)
x^2

# 执行square函数
> square(3)
[1] 9

3.9 批量修改对象 modify_lang()

这是一个神奇的函数,可以方便地替换 list对象、表达式、函数 中的变量定义。

接下来,我们尝试替换list对象中定义的变量a为变量b


# 定义list对象及内部数据
> examples <- list(
+        quote(a <- 5),
+        alist(a = 1, c = a),
+        function(a = 1) a * 10,
+        expression(a <- 1, a, f(a), f(a = a))
+      )

# 查看对象数据
> examples
[[1]]
a <- 5

[[2]]
[[2]]$a
[1] 1

[[2]]$c
a

[[3]]
function (a = 1)
a * 10

[[4]]
expression(a <- 1, a, f(a), f(a = a))

# 定义转换函数a_to_b,
>  a_to_b <- function(x) {
+        if (is.name(x) && identical(x, quote(a))) return(quote(b))
+        x
+  }

# 批量修改对象,替换examples对象中,所有的变量a变成变量b
> modify_lang(examples, a_to_b)
[[1]]
b <- 5

[[2]]
[[2]]$a
[1] 1

[[2]]$c
b

[[3]]
function (a = 1)
b * 10

[[4]]
expression(b <- 1, b, f(b), f(a = b))

3.10 快速创建list对象 dots(), named_dots()

使用dots()函数,我们可以快速创建list对象,通过参数设置来list的数据的名字和值。


# 初始化一个变量
> y <- 2

# 创建list对象
> dots(x = 1, y, z = )
$x
[1] 1

[[2]]
y

$z

# 查看对象类型
> class(dots(x = 1, y, z = ))
[1] "list"

# 查看对象的内部结果
> str(dots(x = 1, y, z = ))
List of 3
 $ x: num 1
 $  : symbol y
 $ z: symbol

使用named_dots()函数,同样我们可以快速创建list对象,通过参数设置list的数据的名字和值。与dots()函数的不同点在于,参数变量就是list的数据的名字,如 变量y在没有赋值情况下,也被用作list数据的名字,并可以通过$y来得到值。


# 创建list对象
> named_dots(x = 1, y, z =)
$x
[1] 1

$y
y

$z

# 查看对象类型
> class(named_dots(x = 1, y, z =))
[1] "list"

# 查看对象的内部结果
> str(named_dots(x = 1, y, z =))
List of 3
 $ x: num 1
 $ y: symbol y
 $ z: symbol

3.11 查找符合条件函数 fun_calls()

使用fun_calls()函数,可以通过过滤条件快速找到函数。

查找base包中所有的函数,找到匹配match.fun字符串的函数名


> find_funs("package:base", fun_calls, "match.fun", fixed = TRUE)
Using environment package:base
 [1] "apply"  "eapply" "Find"   "lapply" "Map"    "mapply" "Negate" "outer"
 [9] "Reduce" "sapply" "sweep"  "tapply" "vapply"

# 查看Map函数,检查是否包括match.fun字符串
> Map
function (f, ...)
{
    f <- match.fun(f)
    mapply(FUN = f, ..., SIMPLIFY = FALSE)
}
<bytecode: 0x21688e0>
<environment: namespace:base>

查找stats包中所有的函数的参数,找到精确匹配FUN字符串的函数名


> find_funs("package:stats", fun_args, "^FUN$")
Using environment package:stats
[1] "addmargins"           "aggregate.data.frame" "aggregate.ts"
[4] "ave"                  "dendrapply"

# 查看ave函数源代码,检查参数名是否有FUN字符串
> ave
function (x, ..., FUN = mean)
{
    if (missing(...))
        x[] <- FUN(x)
    else {
        g <- interaction(...)
        split(x, g) <- lapply(split(x, g), FUN)
    }
    x
}
<bytecode: 0x2acba70>
<environment: namespace:stats>

3.12 查询环境变量 where(), rls(), parenv()

使用where()函数,可以定位对象的在R环境中的位置,有点像Linux的命令whereis。


# 定义一个变量x
> x <- 1
> where("x")
<environment: R_GlobalEnv>

# 查询t.test函数的位置
> where("t.test")
<environment: package:stats>
attr(,"name")
[1] "package:stats"
attr(,"path")
[1] "/usr/lib/R/library/stats"

> t.test
function (x, ...)
UseMethod("t.test")
<bytecode: 0x1ae9bc8>
<environment: namespace:stats>

# 查询mean函数的位置
> where("mean")
<environment: base>

# 查询where函数的位置
> where("where")
<environment: package:pryr>
attr(,"name")
[1] "package:pryr"
attr(,"path")
[1] "/home/conan/R/x86_64-pc-linux-gnu-library/3.0/pryr"

使用rls()函数,可以显示出当前环境的所有变量,包括当前变量,全局变量,空环境变量,命令空间环境变量。


# 打印当前环境的变量
> ls()
 [1] "a"                "Account"          "alice"            "a_to_b"
 [5] "b"                "compact1"         "compact2"         "examples"
 [9] "f"                "f1"               "f2"               "g"
[13] "myGeneric"        "my_long_variable" "plot2"            "union"
[17] "x"                "y"

# 打印所有环境的变量
> rls()
[[1]]
 [1] "a"                          "Account"
 [3] "alice"                      "a_to_b"
 [5] "b"                          ".__C__Account"
 [7] "compact1"                   "compact2"
 [9] ".__C__Person"               "examples"
[11] "f"                          "f1"
[13] "f2"                         "g"
[15] ".__global__"                "myGeneric"
[17] "my_long_variable"           "plot2"
[19] ".Random.seed"               ".requireCachedGenerics"
[21] ".__T__myGeneric:.GlobalEnv" ".__T__union:base"
[23] "union"                      "x"
[25] "y"

使用parenv()函数,可以找到函数调用的上一级环境,从而可以追溯到函数的根。


# 定义一个3层嵌套函数
> adder <- function(x) function(y) function(z) x + y + z

# 调用第一层函数
> add2 <- adder(2)

# 查看函数
> add2
function(y) function(z) x + y + z
<environment: 0x323c000>

# 调用第二层函数
> add3<-add2(3)
> add3
function(z) x + y + z
<environment: 0x3203558>

# 查内层函数的上一级环境
>  parenv(add3)
<environment: 0x323c000>
>  parenv(add2)
<environment: R_GlobalEnv>

3.13 找印调用关系 call_tree(), ast()

使用call_tree()函数,可以打印出表达式的调用关系


# 嵌套函数语句调用
>  call_tree(quote(f(x, 1, g(), h(i()))))
\- ()
  \- `f
  \- `x
  \-  1
  \- ()
    \- `g
  \- ()
    \- `h
    \- ()
      \- `i

# 条件语句调用
> call_tree(quote(if (TRUE) 3 else 4))
\- ()
  \- `if
  \-  TRUE
  \-  3
  \-  4

# 表达式语句调用
> call_tree(expression(1, 2, 3))
\-  1
\-  2
\-  3

使用ast()函数,可以直接打印语句的调用关系


# 嵌套表达式语句
> ast(f(x, 1, g(), h(i())))
\- ()
  \- `f
  \- `x
  \-  1
  \- ()
    \- `g
  \- ()
    \- `h
    \- ()
      \- `i

# 条件语句
> ast(if (TRUE) 3 else 4)
\- ()
  \- `if
  \-  TRUE
  \-  3
  \-  4

# 函数定义
> ast(function(a = 1, b = 2) {a + b})
\- ()
  \- `function
  \- []
    \ a = 1
    \ b = 2
  \- ()
    \- `{
    \- ()
      \- `+
      \- `a
      \- `b
  \- 

# 函数调用
> ast(f()()())
\- ()
  \- ()
    \- ()
      \- `f

3.14 promise对象 uneval(), is_promise()

promise对象:是R语言中延迟加载机制的一部分,包含三个部分:值,表达式和环境。当函数被调用时参数进行匹配,然后每个形式参数会绑定到一个promise上。表达式有形式参数和存储在promise里的函数的指针。

简单来说,延迟加载调用过程就是,先把函数指针存储在promise对象里,并不马上调用;当其实调用发生时,从promise对象里找到函数指针,进行函数的调用。


# 定义变量并赋值
> x <- 10

# 检查是否 promise模式
> is_promise(x)
[1] FALSE

# 匿名函数调用,检查是否 promise模式
> (function(x) is_promise(x))(x = 10)
[1] TRUE

使用uneval()函数,可以在延迟赋值的过程中,打印函数调用方法,而不执行赋值函数调用。


# 定义一个函数
> f <- function(x) {
+     uneval(x)
+ }

# 打印函数调用
> f(a + b)
a + b

> class(f(a+b))
[1] "call"

# 打印函数调用
> f(1 + 4)
1 + 4

# 延迟赋值
> delayedAssign("x", 1 + 4)

# 不执行函数调用,只打印函数调用
> uneval(x)
1 + 4

# 执行函数调用,并赋值
> x
[1] 5

# 延迟赋值又一例
> delayedAssign("x", {
+     for(i in 1:3)
+         cat("yippee!\n")
+     10
+ })

# 执行函数调用,并赋值
> x
yippee!
yippee!
yippee!
[1] 10

3.15 数据绑定%<a-%, %<c-%,%<d-%, rebind,<<-

使用特殊的函数,可以实现数据绑定的功能。

直接绑定


> x %<a-% runif(1)
> x
[1] 0.06793592
> x
[1] 0.8217227

常量绑定


> y %<c-% 4 + 2
[1] 6
> y
[1] 4

延迟绑定


> z %<d-% (a + b)
> a <- 10
> b <- 100
> z
[1] 110

重新绑定


# 对已知变量a重新赋值
> a <- 1
> rebind("a", 2)

# 对未知变量cc重新赋值,出错
> rebind("ccc", 2)
Error: Can't find ccc

# 用 <<- 对已知变量a重新赋值
> a<<-2
> a
[1] 2

# 用 <<- 对未知变量cc重新赋值
> rm(ccc)
> ccc
Error: object 'ccc' not found
> ccc<<-2
> ccc
[1] 2

通过对pryr全面介绍,我们了解这个包的强大,对于R的数据结构的理解非常有帮助。

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

打赏作者