R的极客理想——高级开发篇 (数据分析技术丛书)
Date: 2015-07-01
Publisher: 机械工业出版社

数据分析技术丛书

R的极客理想——高级开发篇

张丹　著

ISBN：978-7-111-50512-9

本书纸版由机械工业出版社于2015年出版，电子版由华章分社（北京华章图文信息有限公司，北京奥维博世图书发行有限公司）全球范围内制作与发行。

版权所有，侵权必究

客服热线：+ 86-10-68995265

客服信箱：service@bbbvip.com

官方网址：www.hzmedia.com.cn

新浪微博 @华章数媒

腾讯微博 @yanfabook

微信公众号 华章电子书（微信号：hzebook）

目录
前言
第一部分　R的计算和算法应用
第1章　R语言知识体系和数学函数
1.1　R语言知识体系概览
1.2　R语言中的数学计算
1.3　概率基础和R语言
1.4　常用连续型分布介绍及R语言实现
1.5　R语言的导数计算
第2章　R语言的算法实现
2.1　用R重写Mahout协同过滤算法
2.2　PageRank算法R语言实现
2.3　二条均线打天下
2.4　R语言中的遗传算法
第二部分　深入R语言程序开发
第3章　R内核编程
3.1　撬动R内核的高级工具包pryr
3.2　揭开R语言中环境空间的神秘面纱
3.3　解密R语言函数的环境空间
3.4　用R进行文件系统管理
3.5　R语言3.1.x版本新特性
第4章　面向对象编程
4.1　R语言面向对象编程
4.2　R语言基于S3的面向对象编程
4.3　R语言基于S4的面向对象编程
4.4　R语言基于RC的面向对象编程
4.5　R语言基于R6的面向对象编程
第三部分　开发自己的R包
第5章　R包开发
5.1　从头开发自己的R包
5.2　标准化R包开发流程
5.3　R语言天气可视化应用
5.4　R包开发——每日中国天气
第6章　R语言游戏之旅
6.1　R语言键盘和鼠标事件
6.2　贪食蛇游戏入门
6.3　R语言游戏框架设计
6.4　R语言制作游戏2048
6.5　发布gridgame游戏包

前言

为什么要写这本书

本书是我写的“R的极客理想”系列丛书的第二本，主要介绍了R语言本身的核心技术、R语言的高级开发应用、R语言与其他学科及知识领域的跨学科综合应用。

其实，早在我的第一本书《R的极客理想——工具篇》中，就已经介绍了R语言的30多个工具包的使用方法，并以IT人的角度，告诉读者如何高效地使用第三方R包，把原有IT知识运用到R语言的学习过程中。但由于一本书的篇幅有限，《R的极客理想——工具篇》只讲了如何使用R语言，没有讲原理。

而本书将弥补这一遗憾，主要介绍R语言本身的核心技术：包括环境空间、面向对象、文件管理、数学计算、R包开发等主题。我希望通过这本书，可以让读者更深入地了解R语言、掌握R语言的核心技术、理解R语言的第三方包的特性，甚至可以自己动手开发出属于自己风格的优秀R包。说不定，不久的将来我会因用到你开发出来的R包而省力不少。

除此之外，本书的另一大亮点就是：R语言与其他学科知识在不同领域的跨学科综合应用。在书中，我将毫无保留地向读者展示：我是怎样将R语言与其他知识相结合，在不同领域让R大放异彩的。相信这部分内容会让很多读者眼前一亮，为之惊叹，原来R还可以这么玩儿！也希望这部分内容可以让大家有所启发，让各行业、各知识领域的朋友都可以接触R，运用R。时至今日，R语言已经不再是局限于科学家们使用的实验室语言，它已经具备了实际开发应用的能力，并且在挖掘数据价值、发现数据规律、创造数据财富等方面极具智慧和创造性！

如果把R语言比作一门武功，《R的极客理想——工具篇》就是兵器使用秘籍（比如什么“打狗棍法”啊、“独孤九剑”啊、“小李飞刀”啊），它可以帮助你在短时间内便捷、有效地提高工作效率，让你在R语言上的修为明显提高，但时间久了，你会因各种原因遇到自己的瓶颈，难以突破。

而本书则是武功的内功心法（比如什么《九阳真经》、《北冥神功》之类的，敬请对号入座，但别拿《葵花宝典》说事儿，谢谢），书中不仅介绍了R语言本身的核心技术，帮你打通任督二脉；而且着重讲述了R语言在实际使用过程中，如何与其他学科、领域结合运用，融会贯通，以无招胜有招，甚至自立门派成为一代宗师，这些都是有可能的！（咳咳，扯远了！）

在这里，我必须再次严肃地强调，本书不是R语言的入门书，零基础的朋友要先补充一些R语言的基础知识！本书包括R语言开发的高级内容，阅读本书，不但需要你有R语言使用经验，而且需要你具备一定的计算机背景知识和使用经验，只有这样，你才能更深刻地体会并运用书中的经验总结。

本书的内容完全是我在R语言的实际使用过程中总结而成的，基本都是我在工作中使用R语言的真实记录，以R语言的高级开发为主，其中还涉及计算机、统计、数学和金融四个学科的知识。

本书的核心内容包括两方面，一方面是R的高级编程，另一方面是跨界知识的综合运用。对于R的高级编程，本书详细总结了R语言的环境空间的定义和使用、文件系统管理、最新版本R 3.1.1的新特性，让你体会R语言的底层设计；全面介绍R语言中四种面向对象体系的程序设计和使用，通过面向对象的程序设计，让R语言有能力做出符合现实世界的复杂应用；另外还介绍了完整的R包开发流程，并提供每日中国天气的应用案例和游戏开发的案例，帮助读者创建自己的R包，打开R语言产品化的思路。

对于跨界知识的综合运用，R语言不仅可以用来非常方便地进行那些让人头疼的数学计算，无论是初等数学或者高等数学，概率或者统计都可以非常轻松、方便的，从此数学变得不再神秘莫测、遥不可及。用R语言还可以创建各种模型，书中算法案例包括协同过滤算法模型、基于矩阵计算的PageRank模型、金融的交易策略模型和遗传算法的使用。几行代码几分钟，就可以让我们头脑中的想法变成可运行的算法原型。

另外，虽然R不是特别适合开发游戏，但如果真用R语言开发游戏2048，也就需要200行代码，还有哪种语言可以匹敌呢？说到这里肯定有人问：“你为什么要用R开发游戏啊？”“为什么不用Java开发啊？”“我不用R开发，用Java开发不是也一样么？”其实，我就是想用这种方式向大家展示R语言简洁的风格、自由的思想、极富想象的创造力，希望用我这个“R极客”的玩耍心态，引发大家对R的无限想象！最后，我们把模型产品化，发布一个属于自己的R包，让全世界的人都能使用，这是一件多么令人兴奋的事情。

在与各界R语言使用者的交流中，我发现，有编程背景的使用者可以写出干净漂亮且运行高效的代码，但由于欠缺统计知识，对模型优化就只能束手无策、无可奈何了；而那些具备统计背景的使用者，虽然可以独立完成一个模型的设计和优化，但对于如何产品化实施就完全找不到办法了。

本书介绍了多个场景案例，不仅从学术的角度完成了模型的设计，而且用计算机的方法实现产品。通过案例的学习，不同学科背景的R语言使用者可以站在其他人的角度，找到新的思维方法。这是本书的又一大亮点！

对于大多数程序员来说，学习R语言比较轻松容易，但运用R语言却非常困难。R语言虽然没有像C/C++一样的复杂程序语法，也不用像Java一样宏观考虑全局架构，更没有JavaScript一样灵活，但是，R语言面向数据本身的编程思想是完全有别于其他编程语言的，这就使得很多程序员在使用R语言时虽然理解语法，但依旧不知道如何应用。

我认为，学习R语言是为了找到个性化的自己，定位自己，综合运用自身的知识进行跨学科创新，而不是去复制别人的想法。R语言的跨界运用，需要你具备基础学科（初等数学、高等数学、线性代数、概率论、统计学）+业务知识（金融、生物、互联网）+IT技术（R语法、R包、数据库、算法）的综合能力，所以只有提升自己的综合知识水平，才能真正地学好R语言。换句话说，一旦你学成R语言，你将是不可替代的。

在此，我不得不再次强调，本书不是入门图书，而是R语言的高级开发图书。本书不讲R的入门语法，也不介绍R语言第三方包的使用。但是，如果你已经具备了一定的R语言基础，想把自己的R语言模型产品化，那么我将告诉你如何提高程序的可靠性和可扩展性，以及如何发布属于自己的R包。

本书是“R的极客理想”系列图书的第二本，第三本《R的极客理想——量化投资篇》将介绍R语言在金融领域的应用，通过R语言构建交易模型，并实现自动化交易的过程，真正地让技术人员把自己的知识变成价值。

本书的使用环境包括Linux Ubuntu和Windows 7两种操作系统，在每一节中都有明确的标识，所有的程序都是在R语言3.1.1版本中测试通过的。

R语言还在不断地进步，它将引导一场数据的革命，跨学科的结合是时代趋势，也是我们的机遇！

读者对象

本书适合以下所有R语言工作者：

·计算机背景的软件工程师；

·R语言的高级使用者；

·数据分析背景的数据科学家；

·统计背景的科研工作者；

·开设相关课程的院校学生。

如何阅读本书

本书的内容分为三个部分。第一部分是R的计算和算法应用（第1~2章），介绍了R语言的知识体系结构，R语言对基础学科的支持，以及通过基础学科实现各种算法，可帮助读者快速了解R语言中的数学计算方法和自定义模型算法开发。

第二部分是深入R语言程序开发（第3~4章），介绍了R语言内核相关的编程，包括环境空间的定义和使用，以及面向对象方法的程序设计和使用，可帮助读者深入了解R语言的底层知识，用面向对象的方法设计复杂的程序结构。

第三部分是开发自己的R包（第5~6章），介绍了R包开发的完整流程，并提供每日中国天气的应用案例和游戏开发的案例，可帮助读者创建自己的R包，打开R语言产品化的思路。

本书有很多综合运用的知识，在阅读本书的时候，建议读者顺序阅读全部的章节。

勘误和支持

由于笔者的水平有限，加之编写时间仓促，书中难免会出现一些错误或者不准确的地方，恳请读者批评指正。为此，笔者创建了一个在线的图书交流网站（http://onbook.me），方便与读者进行沟通。如果读者在阅读过程中遇到问题，也可以在官方网站中留言，我将尽量在线上为你提供最满意的解答。书中的全部源代码，都可以从华章公司网站（www.hzbook.com）或本书交流网站下载，我也会及时更新代码。如果你有什么宝贵意见，欢迎发送邮件至bsspirit@gmail.com，期待能够得到你真挚的反馈。

致谢

感谢我的创业团队成员林伟林和林伟平，是R语言让我们走在了一起。感谢机械工业出版社华章公司的编辑明永玲，帮助我审阅全部章节，引导我顺利完成书稿。感谢我的爸爸、妈妈和爱人，感谢你们对我工作上的支持和生活上的照顾！

谨以此书献给我最亲爱的家人以及众多R语言爱好者们！

张丹

2014年11月于中国北京

第一部分　R的计算和算法应用

■第1章　R语言知识体系和数学函数

■第2章　R语言的算法实现

第1章　R语言知识体系和数学函数

本章为全书开篇，主要介绍了R语言知识体系结构及学习资料。利用R语言实现数学计算和统计计算以及连续型分布函数的可视化，可帮助读者全面理解R语言，并利用R语言快速地处理基础学科的计算问题。

1.1　R语言知识体系概览

问题

如何高效地学习R语言？

引言

最近遇到很多想转行做数据分析的程序员，他们刚开始学习R语言。很多人以为有了其他语言的编程背景，学习R语言就是一件很简单的事情，因而一味地追求速度，但不求甚解。有人说2周就能掌握R语言，但其实掌握的仅仅是R语言的语法，只能算是入门。

R语言的知识体系并非语法这么简单，如果都不了解R的全貌，何谈学好R语言呢？本节将介绍R语言的知识体系结构，并告诉读者如何才能高效地学习R语言。

1.1.1　R语言的知识体系结构

R语言是一门统计语言，主要用于数学建模、统计计算、数据处理、可视化等几个方向，R语言天生就不同于其他的编程语言。R语言封装了各种基础学科的计算函数，我们在R语言编程的过程中只需要调用这些计算函数，就可以构建出面向不同领域、不同业务的、复杂的数学模型。掌握R语言的语法，仅仅是学习R语言的第一步，要学好R语言，需要你要具备基础学科能力（初等数学、高等数学、线性代数、离散数学、概率论、统计学）+业务知识（金融、生物、互联网）+IT技术（R语法、R包、数据库、算法）的结合。所以只有把自己的综合知识水平提升，才真正地学好R语言。换句话说，一旦你学成了R语言，你将是不可被替代的。

1.R语言的知识体系结构概览

R语言的知识体系结构是复杂的，要想学好R语言，就必须把多学科的知识综合运用，所以最大的难点不在于语言本身，而在于使用者的知识基础和综合运用多学科知识的能力。

首先，让我们从宏观上来看R语言的知识体系结构的全貌，如图1-1所示，然后再分别解释每部分的细节。

图1-1　R语言的知识体系结构概览

图1-1中我将R语言知识体系结构分为3个部分：IT技术+业务知识+基础学科。这仅仅是我对R语言的理解，不排除由于个人阅历有限导致观点片面的问题。

IT技术是计算时代必备的技术之一，R语言就是一种我们应该要掌握的技术。

业务知识是市场经验和法则，不管你在什么公司，都会有自己的产品、销售、市场等，你要了解你的公司有什么产品，客户是谁，怎么才能把产品卖给你的客户。

基础学科是我们这十几年在学校学的理论知识，当初学的时候并不知道是为了什么，毕业后如果你还能掌握一些知识并实际运用，那么这将是你最有价值的竞争力。

每个部分的知识单独看都有其局限性，但如果能把知识两两结合起来，就构成了我们现在的各种技术的创新点。

IT技术+业务知识：创造了阿里巴巴的电子商务帝国，还有腾讯全生态链的社交网络。

IT技术+基础学科：创造了Google搜索的神话，还有华尔街金融不败的帝国。

当然，R语言只是一门计算机语言技术，不能独自承担改写历史的重任，但R语言确实给了我们很大的想象空间，让我们能动手去了解这个世界的规律，找到无穷无尽的交叉点，创造出新的帝国。

如果你和我一样，都能站在这个角度来学习和使用R语言，那么我们一定可以成为并肩向前的同路人。

2.R语言的基础知识

蓝图总是宏大和美好的，但具体落实将是困难重重的。接下来，我将会梳理思路，把所有的知识点对应到可操作的文档上，希望帮助大家掌握R语言的全貌！

R语言的基础知识，包括R语言的语法、R语言核心包的使用、R语言的内核编程、R语言包的开发以及R语言的虚拟机。

（1）R语言的语法

语法是我们了解R语言的第一步，和所有人一样，我也曾在很短的时间内就掌握了R语言的语法规则、数据结构、基本类型和常用函数等，但其实R语言语法上的坑，远比你知道的多得多。

我举个例子，看谁能准确地回答。比如，最基础的符号操作“=”“<-”“<<-”，三者有什么区别？分别在什么时候用？不要说问题太偏了，实际根本用不到。我的代码里处处都在用这3个符号，只是你不知道而已。在学习R语言的时候，不要用已经掌握的C、Java、Python的经验直接去套R语言的语法，掉坑里的就是这些人。要从头开始学，一路上没有捷径。

R语言是函数式语言，语法自由，命名自由，使用简单，这只是对于普通用户来说的。作为一个有理想的极客，怎么能只停留在语法上呢？R语言是完全面向对象的，你了解什么是面向对象吗？R语言的面向对象打破了R语言原有的自由，但又要兼容原有的自由语法，多么纠结的设计啊，你能体会到吗？并不是记住了R语言的语法，就代表掌握了R语言。里面各种坑，只有自己踩了，再自己爬出来，才是真正的成长。

（2）R语言核心包的使用

R语言同其他语言一样，在软件启动时，为我们提供了7个核心包，其中包括众多的基础函数，如数学计算函数、统计计算函数、日期函数、包加载函数、数据处理函数、函数操作函数和图形设备函数等。通过search（）函数，可以查看到R启动时默认加载7个核心包。

> search（） # 查看当前环境已加载的R包
[1] ".GlobalEnv" "package：stats" "package：graphics"
[4] "package：grDevices" "package：utils" "package：datasets"
[7] "package：methods" "Autoloads" "package：base"

这7个核心包就是我们构建复杂模型的基础。由于这几个核心包比较底层，很多函数都是用C语言封装的，没有R语言的源代码，而且除了官方文档，几乎没有其他更详细的文档介绍，所以这几个核心包就是学习的门槛。

再问个问题，R语言的所有操作都是函数操作，那么“a<-1：10”语句会被解析为对应什么函数？

> a<-1：10；a # 赋值
[1] 1 2 3 4 5 6 7 8 9 10

答案是，“1：10”对应“seq（）”，“<-”对应assign（）。

> assign（'b'，seq（1：10））；b # 通过函数赋值
[1] 1 2 3 4 5 6 7 8 9 10

这种对应关系的意义在于，因为R语言是解释型语言，我们可以通过传递一个函数A的句柄，让其他的函数B动态调用这个函数A，这就是动态语言中的闭包特性的使用思路。这种思路在JavaScript中已经被广泛使用了，但在R语言中，却只有核心包的一些函数使用这种语法。在R语言中，这种需要有计算机背景知识的地方还有很多，特别是在考虑如何提升R语言的性能时。所以，不要轻易说自己掌握了R语言，要多想想如何才能把其他语言的基础带到R语言的世界里。

（3）R语言的内核编程

R语言的内核编程又是一个比较复杂的计算机学科的问题。R语言的内核编程应该包括哪些内容呢，除了刚才说的R语言的语法和R的核心包，还有面向对象编程、向量化计算、特殊数据类型、环境空间等。本书将会重点介绍这些内容。

面向对象编程是一种理解和抽象现实世界的方法，主要用于解决复杂问题的设计及实现。在Java的世界里，从2003年我开始接触Java的时候，社区就已经在聊面向对象的程序设计了。对于R语言来说，直到2011年发布的2.12版本，才最终有了RC类型的面向对象实现。面向对象的成熟，标志着R语言已经具备了构建复杂大型应用的能力，但如何真正地把面向对象用好，似乎也并不是统计人擅长的。像Hadley Wickham那样有能力写出面向对象代码的人，在R语言的圈子里，实在是太少了。

向量化计算是R语言特有的一种并行计算方式。在R语言中，向量（vector）是R的基本数据类型，当你对一个向量进行操作时，程序会对向量中的每个元素分别计算，计算结果以向量的形式返回。比如，最常见的两个等长的向量相加。

> 1：10+10：1 # 两个向量相加
[1] 11 11 11 11 11 11 11 11 11 11

向量化计算，在R中有很广泛的应用场景，基本可以取代循环计算，高效地完成计算任务。我们定义两个向量，先相加再求和，run1（）函数用向量化计算实现，run2（）用循环方法实现。

> a<-1：100000
> b<-100000：1
> run1<-function（）{ # 向量化计算
+ sum（as.numeric（a+b））
+ }
> run2<-function（）{ # 循环计算
+ c2<-0
+ for（i in 1：length（a））{
+ c2<-a[i]+b[i]+c2
+ }
+ c2
+ }
> system.time（run1（）） # 统计run1（）函数的执行时间用户　　系统　　流逝
0 0 0
> system.time（run2（）） # 统计run2（）函数的执行时间用户 系统 流逝
0.14 0.00 0.14

通过运行程序，我们可以清楚地看出，向量化计算要比循环快。当算法越复杂数据量越大的时候，计算的时间差距会越明显。R语言的编程中的一条经验法则就是用向量计算代替所有的循环计算。

R语言中除了那些基本的数据类型，还有一些高级的特殊数据类型，这些特殊数据类型并不是不常用，而是你不知道。S3类型、S4类型、RC类型分别对应R语言支持的三种面向对象编程的数据结构。环境（environment）类型是由内核定义的一个数据结构，由一系列有层次关系的框架（frame）组成，每个环境对应一个框架，用来区别不同的运行时空间（scope）。

在进行R包开发时，环境空间是必须知道的一个知识点。每个环境空间都是环境类型的一个实例。每个R包都会被加载到一个环境空间中，形成有层次关系的、可调用的空间结构。

我们定义的函数和变量都会存在于R语言的环境空间中，通过ls（）就可以看到当前环境空间中的这些变量，比如，刚才向量化计算定义的变量和函数。

> ls（） # 查看当前环境空间的变量
[1] "a" "b" "run1" "run2"

除了我们自己定义的变量和函数之外，环境空间中还有很多其他的变量和函数，比如sum（）、length（）、system.time（）等，我们可以直接使用这些函数，但是它们并不在当前环境空间中，所以直接用ls（）是查看不到的。当切换到base的环境空间时，就可以找到sum（）的函数定义了。

> ls（pattern="^sum$"，envir=baseenv（）） # 查看base环境空间的变量
[1] "sum"

R语言的内核编程，如同其他语言一样，包括很多的知识细节，并不是只有我提到的这几点。但由于缺少文档，同时R核心技术不普及，所以知道的人不多，会用的人就更少。笔者也在每天探索，期待发现更多的秘密。

（4）R语言包的开发

R语言包的开发是R语言编程中比较困难但又不得不面对的问题，不仅要把上文中所提到的各种R语言技术综合运用在一起，还要符合R语言包的开发规范，并用Latex写好文档，最后提交给CRAN发布。技术问题虽然难，花时间还是可以解决的，但想要在CRAN上发布，那就只能用“难于上青天”来形容了。R语言发展了20多年，只有5000多个包在CRAN上发布，审核不是一般严格啊！我写的gridgame游戏包和chinaWeather天气包，改了很多次都没能通过，都快到要放弃的边缘了。

换个角度想，只有审核严格才能保证用户在安装第三方R语言包的时候不会出错。由于CRAN的审核过于严格，Hadley Wickham也受不了了，他又开发了devtools包，不仅提供了简化R语言包的开发的工具函数，还支持Github社区发布。这样就可以脱离CRAN的束缚，以个人的名义发布各种奇思妙想的R语言包，甚至是“不误正业”的R语言包。

（5）R语言的虚拟机

终于该说我不熟悉的话题了，从我3年多的R语言使用经验来说，还碰不到R语言的虚拟机。不过，网上看到很多高手在生产环境都会重新编译R软件，比如用OpenBLAS加速R的矩阵运算，在虚拟机层实现矩阵的并行化计算，也有用GPU实现矩阵并行计算的；还有牛人把R实现的各种算法都用C++重新实现，然后通过Rcpp封装，直接与R语言的虚拟机进行连接调用。

3.R语言的第三方包

R语言的第三方包，主要包括在CRAN上的5000多个第三方包，以及其他社区中的R语言包，这些包在各种领域中都发挥着重要的作用。在《R的极客理想——工具篇》一书中，我介绍了30多个包的使用，包括基础工具包（fortunes，formatR，rjson，RJSONIO，Cairo，CaTools）、时间序列包（zoo，xts，xtsExtra）、性能监控包（memoise，profr，lineprof）、R跨平台通信包（Rserve，Rsession，rJava）、R服务器包（Rserve，RSclient，FastRWeb，Websocket）、数据库访问包（RMySQL，rmongodb，rredis，RCassandra，RHive），Hadoop操作包（rhdfs，rmr2，rhbase）等。

还有很多常用的包，比如数据处理包（lubridate，plyr，reshape2，stringr，formatR，mcmc）、机器学习包（nnet，rpart，tree，party，lars，boost，e1071，BayesTree，gafit，arules）、可视化包（ggplot2，lattice，googleVis）、地图包（ggmap，RgoogleMaps，rworldmap）等。

R语言对于金融也有很好的支持，有时间序列包（zoo，xts，chron，its，timeDate）、金融分析包（quantmod，RQuantLib，portfolio，quantstrat，blotter，PerformanceAnalytics，TTR，sde，YieldCurve）、风险管理包（parma，evd，evdbayes，evir，extRemes，ismev）等。同时，笔者正在量化投资的创业中，R语言作为系统架构中的算法引擎是在最核心的位置，R语言正用在最有价值的业务中，在后续的《R的极客理想——量化投资篇》一书中，我将会完整地介绍R语言在量化投资系统中的运用。

4.数学的基础知识

数学的基础知识主要包括初等数学、高等数学、线性代数、概率论、统计学等。我们在大学中曾经学过的各种数学，那些不知道有什么用，只为考试而学的数学，是能真正决定R语言掌握深度的基础知识。

当R语言普及、变成大众化的编程语言以后，入门会越来越容易，第三方包的调用会越来越简单，最后就是拼基础学科功底了，数学就是对所有人来说最难的基础学科。

初等数学，咱们中国人一直都在强调数学是我们的优势，其实强的部分仅限于初等数学，加法口诀和乘法口诀让我们可以口算100以内的四则运算。

高等数学，可能是大学里挂科最多的一门课，很多老师照本宣科让很多学生完全不知所云。直到遇到R，我才恍悟为什么最小二乘法能进行最优化的计算。重新捡起高数是学R的必经之路。

线性代数，直到读完Google的PageRank论文的N年后，我自己才想明白，原来矩阵可以处理海量数据的计算，实现分步式算法与单机算法的一致性。

概率论，通过R语言进行各种分步的随机实验，并把概率密度函数曲线应用到实际的业务中，才让我们理解概率才是可以衡量客观事件发生的指标。

统计学，通过R语言我们可以很简单地构建各种统计模型，利用Bayes分类器判断垃圾邮件，利用回归模型预测未来的房价。

是R语言能让我切身地感受到，数学的基础知识在我们实际生活中的运用；也是R语言拉近了学术界和工业界的距离。如果能把我们从小到大学到的知识串起来，我想每个人都会具备与众不同的知识结构，将会在各行各业实现伟大的创新。

5.业务知识

业务知识涉及的面非常广，每个人都可以利用自身所处行业的知识，并结合R语言擅长的领域，发现新的机会。R语言擅长的领域包括统计分析、金融分析、数据挖掘、互联网、生物信息学、生物制药、全球地理科学、数据可视化等。

我在软件和互联网行业待了10年，亲身经历了两个行业的高速发展和变迁。技术一波又一波，每年都有新的主题，一路跟下来的人越来越少，虽然新鲜的血液不断补充着，但这些“血液”的能力和经验却远达不到要求，被市场的浮躁扰动着。近些年，中国的创业公司的成功，少有技术创新，大都是商业模式创新和资本运作的成功。

面对着中国资本市场，掌握好业务方面的知识，就是找到了赚钱的法宝。当业务成熟，在大家都懂得游戏规则后，竞争就会变得异常激烈了，像电商、团购、旅游、酒店、游戏都是如此。新领域新业务，才是值得80后90后年轻人奋斗的方向。如火如荼的O2O、互联网金融、物联网、机器人，也许正是2015年的爆发点。如果你又懂技术又懂业务，学习能力又强，你将是下一个帝国的创造者。

6.跨学科的综合运用能力

再次强调，只要把多种学科知识综合运用，不仅能够成为R语言的一代高手，更能够实现自我的价值。

当IT技术与业务知识完美结合，你会在新兴的市场找到机会。一旦市场成熟后，业务竞争就会变成资本竞争，机会将不复存在。

当IT技术与基础学科相结合，你可以通过科技创新，建立技术壁垒，保持技术优势直到成为行业老大。

如果IT技术、业务知识、基础学科三者同时具备，那么你将是不可被替代的。只要找到属于你的团队，研发出自己的产品，推广给你的用户，你就已经成功了！

R语言可以从IT的角度帮助你实现成功，同时你的成功也将是R语言的成功！

1.1.2　R语言学习

花了很大的篇幅，终于把我理解的R语言的知识体系解释清楚了。那么接下来，我们应该如何高效地学习R语言呢？有句话要说在前头，学习是艰苦的，没有捷径可言，如果你想成功，那么更要面对苦中之苦。正确的学习方法，可以让我们少走弯路，学习别人的经验，会让我们加速成长。

通过上文中对跨学科知识体系的描述，我想大家都应该明白了，要想学好R语言，最大的难点不在于语言本身，而在于使用者的知识基础和综合运用知识的能力。当然，综合运用是要以良好的基础知识为前提的，先抛开业务知识和基础学科的知识不说，只谈IT技术，应该要掌握哪些知识呢？

1.IT基础知识

对于R语言本身来说，我们需要掌握R语言的基础知识，包括R的语法、R核心包的使用、R语言的内核编程、R语言包的开发以及与业务相关的第三方R语言包的使用。

如果你在学习R语言之前，已经有了很多的Java、Python等编程语言的经验，那么这将帮助你很快熟悉R语言，你只要再补充一些数据分析和数据挖掘算法的知识，就能马上将R语言用在实际的工作中了。

如果你之前是SAS或Matlab数据科学家，那你只需要熟悉R语言的编程语法和第三方R语言包，就能用R语言来完成SAS和Matlab的所有任务。

如果你是BI程序员，平时工作经常有处理数据和可视化的任务，那么你可以边学习R语言边补充一些统计方面的知识，从无味的ETL过程中发现数据的价值。[1]

如果你是一名在读的统计学专业学生，R语言将帮助你把书本上枯燥的知识程序化，让你在学习过程中发现社会的规律。

如果你一直在用Excel并抱怨其功能远远不够，请试一下R语言，你的想法很快就会变成你财富的源泉。

如果你是一名宽客（Quant），还不懂R语言的话，那么你很快就会被市场淘汰。

如果你是一名Hadoop算法工程师，用Java写一个MR算法通常要好几千行，你可试试用RHadoop，十分之一的代码行就可以完成同样的事情。

还有很多可举例说明的故事。R语言可以与各种技术、各种思路相结合，让R语言和你已掌握的知识进行碰撞，你就会变得和别人不一样。

2.R语言中文图书

邓一硕（博客http://yishuo.org）曾经写过一篇名为《R语言书籍的学习路线图书》的博文，这篇文章很有参考意义。文章分别介绍了R语言的初级入门、高级入门、绘图与可视化、计量经济学、时间序列分析和金融等内容，涉及30多本R语言图书和小册子，但大部分是英文的。

随着时间的推移，这两年R语言方面又增加了好多本新书，中文图书也慢慢地多了起来。我重新定义的R语言中文图书学习路线图，如图1-2所示。

图1-2　R语言中文图书学习路线图

对于不同层次的R语言用户，也有了市场细分。入门的朋友可以从《R语言编程艺术》开始学习；有一定R语言基础的朋友可以阅读《R语言实战》；需要扩展知识面的朋友可以阅读《R的极客理想——工具篇》；在掌握了R语言的各种入门技术后，高级的R语言开发者可以阅读本；用R做可视化的朋友，可以阅读《ggplot2：数据分析与图形艺术》；正在学习统计学的朋友，可以阅读《统计建模与R软件》；准备用R做金融的朋友，可以阅读《时间序列分析及应用：R语言（原书第2版）》和《金融数据分析导论：基于R语言》。

以上推荐的图书，我都亲自读过，予以品质保证。此图书列表将在我的博客中不定期更新，把我读到的好书分享给大家！

3.R语言中文社区

除了图书，中文的R语言社区和个人博客也在蓬勃发展。统计之都是中国大陆最权威的R语言组织，其中不仅积累了大量高质量的R语言文章，并主办了七届中国R语言会议。统计之都团队成员，还参与翻译了《R语言编程艺术》《R语言实战》《ggplot2：数据分析与图形艺术》《R语言核心技术手册（第2版）》《R数据可视化手册》《R语言统计入门（第2版）》等多本图书。

炼数成金论坛，以数据分析为主题，设有R语言板块，提供在线的R语言入门培训，黄志洪老师的算法讲解超一流。

人大经济论坛，以经管教育为主题，设有R语言板块，以线下培训为主。

4.R语言中文博客

笔者的个人博客——粉丝日志（http://blog.fens.me），原创了大量的R语言技术实战文章，包括R的极客理想系列文章、RHadoop实践系列文章、R利剑NoSQL系列文章，并写作“R的极客理想”系列图书。

谢益辉的个人博客（http://yihui.name），博客中主要包括各种有趣的技术和吐槽文章。谢益辉是统计之都的创始人，现任RStudio公司程序员。

刘思喆的个人博客——贝吉塔行星（http://www.bjt.name），博客中主要包括R语言企业级应用的文章。刘思喆现任京东推荐算法经理。

李舰的个人博客（http://jliblog.com），博客中主要包括R语言建模的文章。李舰现任Mango Solutions中国区数据总监。

邓一硕的个人博客——格物堂（http://yishuo.org），博客中主要包括R语言金融数据分析的文章。

阿稳的个人博客——不周山（http://www.wentrue.net/blog），博客中主要包括R语言并行技术的文章。

最后，祝大家把R语言学好用好，在各自的领域中找到创新的突破口，实现自我价值，然后反馈给R语言社区，加速R语言的发展壮大。

[1] ETL即数据抽取（Extract）、转换（Transform）、装载（Load）的过程。

1.2　R语言中的数学计算

问题

如何用R语言进行数学计算？

引言

R语言是统计语言，生来就对数学有良好的支持，用R语言做数学的计算题特别方便。如果计算器中能嵌入R语言的计算函数，那么绝对是一种高科技产品。我真的把R语言当成我的计算器了！

1.2.1　基本计算

R语言对数学计算有着非常好的支持，本节将完整介绍初等数学中的各种计算操作。

本节的系统环境是：

·Windows 7 64bit

·R：3.1.1 x86_64-w64-mingw32/x64（64-bit）

用R语言实现四则运算操作，包括加、减、乘、除、余数、整除、绝对值、判断正负。

> a<-10；b<-5 # 定义2个变量
> a+b；a-b；a*b；a/b # 加减乘除
[1] 15
[1] 5
[1] 50
[1] 2
> a%%b；a%/%b # 余数，整除
[1] 0
[1] 2
> abs（-a） # 绝对值
[1] 10
> sign（-2：3） # 判断正负
[1] -1 -1 0 1 1 1

用R语言实现数学计算操作，包括幂、自然常数e的幂、平方根、对数。

> a<-10；b<-5；c<-4 # 定义3个变量
> c^b；c^-b；c^（b/10） # 幂运算
[1] 1024
[1] 0.0009765625
[1] 2
> exp（1） # 取自然常数e
[1] 2.718282
> exp（3） # 自然常数e的幂
[1] 20.08554
> sqrt（c） # 平方根
[1] 2
> log2（c） # 以2为底的对数
[1] 2
> log10（b） # 以10为底的对数
[1] 0.69897
> log（c，base = 2） # 自定义底的对数
[1] 2
> log（a，base=exp（1）） # 自然常数e的对数
[1] 2.302585
> log（a^b，base=a） # 指数对数操作
[1] 5
> log（exp（3））
[1] 3

用R语言实现比较计算操作，包括==、>、<、！=、<=、>=、isTRUE、identical。

> a<-10；b<-5 # 定义2个变量
> a==a；a！=b；a>b；a<b；a<=b；a>=c # 比较计算
[1] TRUE
[1] TRUE
[1] TRUE
[1] FALSE
[1] FALSE
[1] TRUE
> isTRUE（a） # 判断是否为TRUE
[1] FALSE
> isTRUE（！a）
[1] FALSE
> identical（1， as.integer（1）） # 精确比较两个对象
[1] FALSE
> identical（NaN， -NaN）
[1] TRUE
> f <- function（x） x
> g <- compiler：：cmpfun（f）
> identical（f， g）
[1] TRUE

用R语言实现逻辑计算操作，包括&、|、&&、||、xor。

> x<-c（0，1，0，1） # 定义2个向量
> y<-c（0，0，1，1）
> x && y；x || y # 只比较向量的第一个元素 &&， ||
[1] FALSE
[1] FALSE
> x & y；x | y # S4对象的逻辑运算，比较所有元素 &， |
[1] FALSE FALSE FALSE TRUE
[1] FALSE TRUE TRUE TRUE
> xor（x，y） # 异或比较
[1] FALSE TRUE TRUE FALSE
> xor（x，！y）
[1] TRUE FALSE FALSE TRUE

用R语言实现约数计算操作，包括ceiling、floor、trunc、round、signif。

> ceiling（5.4） # 向上取整
[1] 6
> floor（5.8） # 向下取整
[1] 5
> trunc（3.9） # 取整数
[1] 3
> round（5.8） # 四舍五入
[1] 6
> round（5.8833， 2） # 四舍五入，并保留2位小数
[1] 5.88
> signif（5990000，2） # 四舍五入，保留前2位整数
[1] 6e+06

用R语言实现数组计算操作，包括求最大值、求最小值、范围、求和、均值、加权平均、连乘、差分、秩、中位数、分位数、任意数、全体数。

> d<-seq（1，10，2）；d # 定义1个向量
[1] 1 3 5 7 9
> max（d）；min（d）；range（d） # 求最大值、最小值、范围range
[1] 9
[1] 1
[1] 1 9
> sum（d）；mean（d） # 求和、均值
[1] 25
[1] 5
> weighted.mean（d，rep（1，5）） # 加权平均
[1] 5
> weighted.mean（d，c（1，1，2，2，2））
[1] 5.75
> prod（1：5） # 连乘
[1] 120
> diff（d） # 差分
[1] 2 2 2 2
> rank（d） # 秩
[1] 1 2 3 4 5
> median（d） # 中位数
[1] 5
> quantile（d） # 分位数
0% 25% 50% 75% 100%
1 3 5 7 9
> any（d<5）；all（d<5） # 任意条件any，全体条件all
[1] TRUE
[1] FALSE

用R语言实现排列组合计算操作，包括阶乘、组合、排列。

> factorial（5） # 阶乘5！
[1] 120
> choose（5， 2） # 组合，从5个中选出2个
[1] 10
> combn（5，2） # 列出从5个中选出2个的所有组合项
[，1] [，2] [，3] [，4] [，5] [，6] [，7] [，8] [，9] [，10]
[1，] 1 1 1 1 2 2 2 3 3 4
[2，] 2 3 4 5 3 4 5 4 5 5
> for （n in 0：10） print（choose（n， k = 0：n）） # 计算0：10的组合个数
[1] 1
[1] 1 1
[1] 1 2 1
[1] 1 3 3 1
[1] 1 4 6 4 1
[1] 1 5 10 10 5 1
[1] 1 6 15 20 15 6 1
[1] 1 7 21 35 35 21 7 1
[1] 1 8 28 56 70 56 28 8 1
[1] 1 9 36 84 126 126 84 36 9 1
[1] 1 10 45 120 210 252 210 120 45 10 1
> choose（5， 2）*factorial（2） # 排列，从5个中选出2个
[1] 20

用R语言实现累积计算操作，包括累加、累乘、最小累积、最大累积。

> cumsum（1：5） # 累加
[1] 1 3 6 10 15
> cumprod（1：5） # 累乘
[1] 1 2 6 24 120
> e<-seq（-3，3）；e # 定义一个向量
[1] -3 -2 -1 0 1 2 3
> cummin（e） # 最小累积cummin
[1] -3 -3 -3 -3 -3 -3 -3
> cummax（e） # 最大累积cummax
[1] -3 -2 -1 0 1 2 3

用R语言实现两个数组的计算操作，包括取交集、并集、差集、数组是否相等、取唯一、查匹配元素的索引、找重复元素索引。

> x <- c（9：20， 1：5， 3：7， 0：8）；x # 定义两个数组向量
[1] 9 10 11 12 13 14 15 16 17 18 19 20 1 2 3 4 5
[18] 3 4 5 6 7 0 1 2 3 4 5 6 7 8
> y<- 1：10；y
[1] 1 2 3 4 5 6 7 8 9 10
> intersect（x，y） # 交集
[1] 9 10 1 2 3 4 5 6 7 8
> union（x，y） # 并集
[1] 9 10 11 12 13 14 15 16 17 18 19 20 1 2 3 4 5
[18] 6 7 0 8
> setdiff（x，y） # 差集，从x中排除y
[1] 11 12 13 14 15 16 17 18 19 20 0
> setequal（x， y） # 判断是否相等
[1] FALSE
> unique（c（x，y）） # 取唯一
[1] 9 10 11 12 13 14 15 16 17 18 19 20 1 2 3 4 5
[18] 6 7 0 8
> which（x %in% y） # 找到x在y中存在的元素的索引
[1] 1 2 13 14 15 16 17 18 19 20 21 22 24 25 26 27 28
[18] 29 30 31
> which（is.element（x，y）） # 同%in%
[1] 1 2 13 14 15 16 17 18 19 20 21 22 24 25 26 27 28
[18] 29 30 31
> which（duplicated（x）） # 找到重复元素的索引
[1] 18 19 20 24 25 26 27 28 29 30

1.2.2　三角函数计算

1.三角函数

在直角三角形中仅有锐角（大小在0~90度之间的角）三角函数的定义。给定一个锐角θ，可以做出一个直角三角形，使得其中的一个内角是θ。设这个三角形中，θ的对边、邻边和斜边长度分别是a、b和h，如图1-3所示。

图1-3　直角三角形

三角函数的6种关系：正弦、余弦、正切、余切、正割、余割。

·θ的正弦是对边与斜边的比值：sinθ=a/h

·θ的余弦是邻边与斜边的比值：cosθ=b/h

·θ的正切是对边与邻边的比值：tanθ=a/b

·θ的余切是邻边与对边的比值：cotθ=b/a

·θ的正割是斜边与邻边的比值：secθ=h/b

·θ的余割是斜边与对边的比值：cscθ=h/a

三角函数的特殊值。

用R语言实现三角基本函数计算，包括正弦、余弦、正切。

> sin（0）；sin（1）；sin（pi/2） # 正弦
[1] 0
[1] 0.841471
[1] 1
> cos（0）；cos（1）；cos（pi） # 余弦
[1] 1
[1] 0.5403023
[1] -1
> tan（0）；tan（1）；tan（pi） # 正切
[1] 0
[1] 1.557408
[1] -1.224647e-16

接下来，我们用ggplot2包来画出三角函数的图形。

> library（ggplot2） # 加载ggplot2的库
> library（scales）

三角函数画图，以下代码生成三角函数曲线，如图1-4所示。

> x<-seq（-2*pi，2*pi，by=0.01） # x坐标
> s1<-data.frame（x，y=sin（x），type=rep（'sin'，length（x））） # y坐标，正弦
> s2<-data.frame（x，y=cos（x），type=rep（'cos'，length（x））） # y坐标，余弦
> s3<-data.frame（x，y=tan（x），type=rep（'tan'，length（x））） # y坐标，正切
> s4<-data.frame（x，y=1/tan（x），type=rep（'cot'，length（x））） # y坐标，余切
> s5<-data.frame（x，y=1/cos（x），type=rep（'sec'，length（x））） # y坐标，正割
> s6<-data.frame（x，y=1/sin（x），type=rep（'csc'，length（x））） # y坐标，余割
> df<-rbind（s1，s2，s3，s4，s5，s6）
> g<-ggplot（df，aes（x，y）） # 用ggplot2画图
> g<-g+geom_line（aes（colour=type，stat='identity'））
> g<-g+scale_y_continuous（limits=c（-2， 2））
> g<-g+scale_x_continuous（breaks=seq（-2*pi，2*pi，by=pi），labels=c（"-2*pi"，
"-pi"，"0"，"pi"，"2*pi"））
> g

图1-4　三角函数曲线

2.反三角函数

基本的反三角函数定义如下。

用R语言实现反三角函数的计算，包括反正弦、反余弦、反正切。

> asin（0）；asin（1） # 反正弦asin
[1] 0
[1] 1.570796 # pi/2=1.570796
> acos（0）；acos（1） # 反余弦acos
[1] 1.570796 # pi/2=1.570796
[1] 0
> atan（0）；atan（1） # 反正切atan
[1] 0
[1] 0.7853982 # pi/4=0.7853982

反三角函数画图，以下代码生成反三角函数曲线，如图1-5所示。

> x<-seq（-1，1，by=0.005） # x坐标
> s1<-data.frame（x，y=asin（x），type=rep（'arcsin'，length（x））） # y坐标，反正弦
> s2<-data.frame（x，y=acos（x），type=rep（'arccos'，length（x））） # y坐标，反余弦
> s3<-data.frame（x，y=atan（x），type=rep（'arctan'，length（x））） # y坐标，反正切
> s4<-data.frame（x，y=1/atan（x），type=rep（'arccot'，length（x））） # y坐标，反余弦
> s5<-data.frame（x，y=1/asin（x），type=rep（'arcsec'，length（x））） # y坐标，反正割
> s6<-data.frame（x，y=1/acos（x），type=rep（'arccsc'，length（x））） # y坐标，反余弦
> df<-rbind（s1，s2，s3，s4，s5，s6）
> g<-ggplot（df，aes（x，y）） # 用ggplot2画图
> g<-g+geom_line（aes（colour=type，stat='identity'））
> g<-g+scale_y_continuous（limits=c（-2*pi，2*pi），breaks=seq（-2*pi，2*pi，by=pi），
labels=c（"-2*pi"，"-pi"，"0"，"pi"，"2*pi"））
> g

图1-5　反三角函数曲线

3.三角函数公式

接下来，用单元测试的方式来描述三角函数的数学公式，公式的左边等于公式的右边。通过testthat包进行单元测试，关于testthat包的安装和使用，请参考5.2节。

使用expect_that（right，left）函数，把公式的左右两边表达式，分别以参数形式传入函数中。运行expect_that（）函数，如果没有返回结果则表示两个参数相等，如果有输出则根据输出查看原因。

> library（testthat） # 加载testthat包
> a<-5；b<-10 # 定义变量

平方和公式：

> sin（a）^2+cos（a）^2
[1] 1
> expect_that（1， equals（sin（a）^2+cos（a）^2）） # 用单元测试的方法，判断公式是否两边相等
> expect_that（2， equals（sin（a）^2+cos（a）^2）） # 如果公式两边不相等，会有错误提示
Error： 2 not equal to sin（a）^2 + cos（a）^2
Mean relative difference： 1

和角公式：

和角公式的单元测试如下：

> expect_that（sin（a）*cos（b）+sin（b）*cos（a），equals（sin（a+b）））
> expect_that（sin（a）*cos（b）-sin（b）*cos（a），equals（sin（a-b）））
> expect_that（cos（a）*cos（b）-sin（b）*sin（a），equals（cos（a+b）））
> expect_that（cos（a）*cos（b）+sin（b）*sin（a），equals（cos（a-b）））
> expect_that（（tan（a）+tan（b））/（1-tan（a）*tan（b）），equals（tan（a+b）））
> expect_that（（tan（a）-tan（b））/（1+tan（a）*tan（b）），equals（tan（a-b）））

2倍角公式：

2倍角公式的单元测试如下：

> expect_that（cos（a）^2-sin（a）^2，equals（cos（2*a）））
> expect_that（2*cos（a）^2-1，equals（cos（2*a）））
> expect_that（1-2*sin（a）^2，equals（cos（2*a）））

3倍角公式：

3倍角公式的单元测试如下：

> expect_that（4*cos（a）^3-3*cos（a），equals（cos（3*a）））
> expect_that（-4*sin（a）^3+3*sin（a），equals（sin（3*a）））

半角公式：

半角公式的单元测试如下：

> expect_that（sqrt（（1-cos（a））/2），equals（abs（sin（a/2））））
> expect_that（sqrt（（1+cos（a））/2），equals（abs（cos（a/2））））
> expect_that（sqrt（（1-cos（a））/（1+cos（a））），equals（abs（tan（a/2））））
> expect_that（abs（sin（a）/（1+cos（a））），equals（abs（tan（a/2））））
> expect_that（abs（（1-cos（a））/sin（a）），equals（abs（tan（a/2））））

和差化积：

和差化积公式的单元测试如下：

> expect_that（（sin（a+b）+sin（a-b））/2，equals（sin（a）*cos（b）））
> expect_that（（sin（a+b）-sin（a-b））/2，equals（cos（a）*sin（b）））
> expect_that（（cos（a+b）+cos（a-b））/2，equals（cos（a）*cos（b）））
> expect_that（（cos（a-b）-cos（a+b））/2，equals（sin（a）*sin（b）））

积化和差：

积化和差公式的单元测试如下：

> expect_that（sin（a）+sin（b），equals（2*sin（（a+b）/2）*cos（（a-b）/2）））
> expect_that（sin（a）-sin（b），equals（2*cos（（a+b）/2）*sin（（a-b）/2）））
> expect_that（2*cos（（a+b）/2）*cos（（a-b）/2），equals（cos（a）+cos（b）））
> expect_that（-2*sin（（a+b）/2）*sin（（a-b）/2），equals（cos（a）-cos（b）））

万能公式：

万能公式的单元测试如下：

> expect_that（sin（2*a），equals（2*tan（a）/（1+tan（a）^2）））
> expect_that（（1-tan（a）^2）/（1+tan（a）^2），equals（cos（2*a）））
> expect_that（2*tan（a）/（1-tan（a）^2），equals（tan（2*a）））

平方差公式：

平方差公式的单元测试如下：

> expect_that（sin（a）^2-sin（b）^2，equals（sin（a+b）*sin（a-b）））
> expect_that（cos（a）^2-sin（b）^2，equals（cos（a+b）*cos（a-b）））

降次升角公式：

降次升角公式的单元测试如下：

> expect_that（（1+cos（2*a））/2，equals（cos（a）^2））
> expect_that（（1-cos（2*a））/2，equals（sin（a）^2））

辅助角公式：

辅助角公式的单元测试如下：

> expect_that（sqrt（a^2+b^2）*sin（a+atan（b/a）），equals（a*sin（a）+b*cos（a）））

1.2.3　复数计算

复数为实数的延伸，它使任一多项式都有根。复数中的虚数单位i，是-1的一个平方根，即i^2=-1。任一复数都可表达为x+yi，其中x及y皆为实数，分别称为复数之“实部”和“虚部”。

1.创建一个复数

> ai<-5+2i；ai # 直接创建复数
[1] 5+2i
> class（ai） # 查看复数的类型
[1] "complex"
> bi<-complex（real=5，imaginary=2）；bi # 通过complex（）函数创建复数
[1] 5+2i
> is.complex（bi）
[1] TRUE
> Re（ai） # 实数部分
[1] 5
> Im（ai） # 虚数部分
[1] 2
> Mod（ai） # 取模
[1] 5.385165 # sqrt（5^2+2^2） = 5.385165
> Arg（ai） # 取辐角
[1] 0.3805064
> Conj（ai） # 取轭
[1] 5-2i

2.复数四则运算

·加法公式：（a+bi）+（c+di）=（a+c）+（b+d）i

·减法公式：（a+bi）-（c+di）=（a-c）+（b-d）i

·乘法公式：（a+bi）（c+di）=ac+adi+bci+bidi=ac+bdi^2+（ad+bc）i=（ac-bd）+（ad+bc）i

·除法公式：（a+bi）/（c+di）=（（ac+bd）+（bc-ad）i）/（c^2+d^2）

> a<-5；b<-2；c<-3；d<-4
> ai<-complex（real=a，imaginary=b）
> bi<-complex（real=c，imaginary=d）

复数四则运算的单元测试如下：

> expect_that（complex（real=（a+c），imaginary=（b+d）），equals（ai+bi））
> expect_that（complex（real=（a-c），imaginary=（b-d）），equals（ai-bi））
> expect_that（complex（real=（a*c-b*d），imaginary=（a*d+b*c）），equals（ai*bi））
> expect_that（complex（real=（a*c+b*d），imaginary=（b*c-a*d））/（c^2+d^2），equals（ai/bi））

3.复数开平方根

> sqrt（-9） # 在实数域，给-9开平方根
[1] NaN
Warning message：
In sqrt（-9） ： NaNs produced
> sqrt（complex（real=-9）） # 在复数域，给-9开平方根
[1] 0+3i

1.2.4　方程计算

方程计算是数学计算的一种基本形式，R语言也可以很方便地帮助我们解方程，下面将介绍一元多次方程和二元一次方程的解法。解一元多次方程，可以用uniroot（）函数。

1.一元一次方程

一元一次方程：ax+b=0，设a=5，b=10，求x？

> f1 <- function （x， a， b） a*x+b # 定义方程函数
> a<-5；b<-10 # 给a，b常数赋值
> result <- uniroot（f1，c（-10，10），a=a，b=b，tol=0.0001） # 在（-10，10）的区间，精确度
# 为0.0001位，计算方程的根
> result$root # 打印方程的根x
[1] -2

一元一次方程非常容易解得，方程的根是-2！以图形展示函数：y=5x+10，如图1-6所示。

> x<-seq（-5，5，by=0.01） # 创建数据点
> y<-f1（x，a，b）
> df<-data.frame（x，y）
> g<-ggplot（df，aes（x，y）） # 用ggplot2来画图
> g<-g+geom_line（col='red'） # 红色直线
> g<-g+geom_point（aes（result$root，0），col="red"，size=3） # 点
> g<-g+geom_hline（yintercept=0）+geom_vline（yintercept=0） # 坐标轴
> g<-g+ggtitle（paste（"y ="，a，"* x +"，b））
> g

图1-6　函数y=5x+10

2.一元二次方程

一元二次方程：ax^2+bx+c=0，设a=1，b=5，c=6，求x？

> f2 <- function （x， a， b， c） a*x^2+b*x+c
> a<-1；b<-5；c<-6
> result <- uniroot（f2，c（0，-2），a=a，b=b，c=c，tol=0.0001）
> result$root
[1] -2

把参数带入方程，用uniroot（）函数，我们就解出了方程的一个根，改变计算的区间，我们就可以得到另一个根。

> result <- uniroot（f2，c（-4，-3），a=a，b=b，c=c，tol=0.0001）
> result$root
[1] -3

方程的两个根，一个是-2，一个是-3。

由于uniroot（）函数每次只能计算一个根，而且要求输入的区间端点值必须是正负号相反的。如果我们直接输入（-10，0）这个区间，那么uniroot（）函数会出现错误。

> result <- uniroot（f2，c（-10，0），a=a，b=b，c=c，tol=0.0001）
Error in uniroot（f2， c（-10， 0）， a = a， b = b， c = c， tol = 1e-04） ：
# 位于极点边的f（）值之正负号不相反

这应该是uniroot（）为了统计计算一元多次方程而设计的，所以为了使用uniroot（）函数，我们需要取不同的区间来获得方程的根。以图形展示函数：y=x^2+5x+6，如图1-7所示。[1]

> x<-seq（-5，1，by=0.01） # 创建数据点
> y<-f2（x，a，b，c）
> df<-data.frame（x，y）
> g<-ggplot（df，aes（x，y）） # 用ggplot2来画图
> g<-g+geom_line（col='red'） # 红色曲线
> g<-g+geom_hline（yintercept=0）+geom_vline（yintercept=0） # 坐标轴
> g<-g+ggtitle（paste（"y ="，a，"* x ^ 2 +"，b，"* x +"，c））
> g

图1-7　函数y=x^2+5x+6

我们从图1-7中可以很明显看到x的两个根的取值范围。

3.一元三次方程

一元三次方程：ax^3+bx^2+cx+d=0，设a=1，b=5，c=6，d=-11，求x？

> f3 <- function （x， a， b， c，d） a*x^3+b*x^2+c*x+d
> a<-1；b<-5；c<-6；d<--11
> result <- uniroot（f3，c（-5，5），a=a，b=b，c=c，d=d，tol=0.0001）
> result$root
[1] 0.9461458

如果我们设置对了取值区间，那么很容易就可以得到方程的根。以图形展示函数：y=x^3+5x^2+6x-11，如图1-8所示。

> x<-seq（-5，5，by=0.01） # 创建数据点
> y<-f3（x，a，b，c，d）
> df<-data.frame（x，y）
> g<-ggplot（df，aes（x，y）） # 用ggplot2画图
> g<-g+geom_line（col='red'） # 3次曲线
> g<-g+geom_hline（yintercept=0）+geom_vline（yintercept=0） # 坐标轴
> g<-g+ggtitle（paste（"y ="，a，"* x ^ 3 +"，b，"* x ^2 +"，c，"* x + "，d））
> g

图1-8　函数y=x^3+5x^2+6x-11

4.二元一次方程组

R语言还可以用来解二元方程组，当然计算方法其实是利用了矩阵计算。

下面是x_1，x_2两个未知变量组成的方程组，求x_1，x_2的值。

以矩阵形式来构建方程组就是

> lf<-matrix（c（3，5，1，2），nrow=2，byrow=TRUE） # 左矩阵
> rf<-matrix（c（4，1），nrow=2） # 右矩阵
> result<-solve（lf，rf） # 计算结果
> result
[，1]
[1，] 3
[2，] -1

得方程组的解，x_1，x_2分别为3和-1。

接下来，我们画出这两个线性方程的图，如图1-9所示。设y=x_2，x=x_1，把原方程组变成两个函数形式。

> fy1<-function（x） （-3*x+4）/5 # 定义2个函数
> fy2<-function（x） （-1*x+1）/2
> x<-seq（-1，4，by=0.01） # 定义数据
> y1<-fy1（x）
> y2<-fy2（x）
> dy1<-data.frame（x，y=y1，type=paste（"y=（-3*x+4）/5"））
> dy2<-data.frame（x，y=y2，type=paste（"y=（-1*x+1）/2"））
> df <- rbind（dy1，dy2）
> g<-ggplot（df，aes（x，y）） # 用ggplot2画图
> g<-g+geom_line（aes（colour=type，stat='identity'）） # 2条直线
> g<-g+geom_hline（yintercept=0）+geom_vline（yintercept=0） # 坐标轴
> g

图1-9　二元一次方程组

我们看到两条直线交点的坐标就是方程组的两个根。多元一次方程同样可以用这种方法来解得。

通过R语言，我们实现了对初等数学的各种计算，真的是非常方便。

[1] 请读者自己运行R语言代码，查看生成的彩色图。

1.3　概率基础和R语言

问题

如何用R语言学习概率？

引言

R语言是统计语言，概率又是统计的基础，所以可以想到，R语言必然要从底层API上提供完整、方便、易用的概率计算的函数。下面就让R语言帮我们学好概率的基础课。

1.3.1　随机变量介绍

随机变量（random variable）表示随机现象各种结果的实值函数，定义在样本空间S上。由于它的自变量是随机试验的结果，而随机试验结果的出现具有随机性，因此，随机变量的取值具有一定的随机性。样本空间是随机试验的一切可能的基本结果组成的集合，记为S。样本空间的元素，即随机试验的每一个可能的结果，称为样本点。

如果随机变量x的全部可能的取值只有有限多个，则称x为离散型随机变量。如果随机变量可以在某个区间内取任意实数，即变量的取值可以是连续的无穷多个，这种随机变量就称为连续型随机变量。

本节的系统环境是：

·Windows 7 64bit

·R：3.1.1 x86_64-w64-mingw32/x64（64-bit）

R程序：生成在样本空间（1，2，3，4，5）上的离散型随机变量X，X只能取值1，2，3，4或5。

> S<-1：5
> x<-sample（S，1）；x
[1] 2

下面的程序生成在样本空间（0，1）上的连续随机变量Y，取10个值。

> y<-runif（10，0，1）；y
[1] 0.3819569 0.7609549 0.6692581 0.6314708 0.5552201 0.8225527 0.7633086
0.4667188 0.1883553 0.3741653

概率分布用以表述随机变量取值的概率规律。为了方便使用，根据随机变量所属类型的不同，概率分布取不同的表现形式。

·离散型分布：两点分布、二项分布、泊松分布等

·连续型分布：均匀分布、指数分布、正态分布、伽玛分布等

在1.4节中，将介绍连续型分布函数的R语言实现。

1.3.2　随机变量的数字特征

接下来，我们将介绍随机变量的数字特征，这些指标特征都是概率论中常用的概念。数学期望、方差、标准差、分位数（最大值、最小值、中位数、四分位数）、协方差、相关系数、矩（包括原点矩、中心矩、偏度、峰度）、协方差矩阵。

1.数学期望

离散型随机变量的一切可能的取值xi与对应的概率pi之积的和称为该离散型随机变量的数学期望（mathematical expectation），记为E（X），如公式（1.1）所示。数学期望是最基本的数学特征之一，反映随机变量平均取值的大小。我们通常也把数学期望也叫做均值。

下面的R程序计算数据集（1，2，3，7，21）的数学期望。

> S<-c（1，2，3，7，21）
> mean（S） # 计算样本的数学期望
[1] 6.8

连续型随机变量：若随机变量X的分布函数F（x）可表示成一个非负可积函数f（x）的积分，则称X为连续型随机变量，f（x）称为X的概率密度函数，积分值为X的数学期望，记为E（X），如公式（1.2）所示。

2.方差

方差（variance）是各个数据与平均数之差的平方的平均数，用来度量随机变量与其数学期望之间的偏离程度。设X为随机变量，如果E{[X-E（X）]2}存在，则称E{[X-E（X）]2}为X的方差，记为Var（X），如公式（1.3）所示。

下面的R程序计算数据集（1，2，3，7，21）的方差。

> S<-c（1，2，3，7，21）
> var（S） # 计算样本的方差
[1] 68.2
> sum（（S-mean（S））^2）/（length（S）-1） # 手动计算样本的方差
[1] 68.2

3.标准差

标准差（standard deviation）是方差的算术平方根，反映一个数据集的离散程度。两个数据集的平均数相同，但标准差未必相同。下面的R程序计算数据集（1，2，3，7，21）的标准差。

> S<-c（1，2，3，7，21）
> sd（S） # 计算样本的标准差
[1] 8.258329

4.分位数

众数（mode）是一组数据中出现次数最多的数值，有时众数在一组数中有好几个。下面的R程序计算数据集（1，2，3，3，3，7，7，7，7，9，10，21）的众数。

> S<-c（1，2，3，3，3，7，7，7，7，9，10，21）
> names（which.max（table（S））） # 计算众数
[1] "7"

最小值（minimum）是在给定情形下可以达到的最小数量或最小数值。下面的R程序计算数据集（2，3，3，3，7，7，7，7，9，10，21）的最小值。

> S<-c（2，3，3，3，7，7，7，7，9，10，21）
> min（S） # 最小值
[1] 2
> which.min（S） # 最小值的索引
[1] 1

最大值（maximum）是在给定情形下可以达到的最大数量或最大数值。下面的R程序计算数据集（2，3，3，3，7，7，7，7，9，10，21）的最大值。

> S<-c（2，3，3，3，7，7，7，7，9，10，21）
> max（S） # 最大值
[1] 21
> which.max（S） # 最大值的索引
[1] 11

中位数（median）是指将统计总体当中的各个变量值按大小顺序排列起来，形成一个数列，处于变量数列中间位置的变量值就称为中位数。下面的R程序计算数据集（1，2，3，4，5）的中位数。

> S<-c（1，2，3，4，5）
> median（S） # 中位数
[1] 3

四分位数（quartile）用于描述任何类型的数据，尤其是偏态数据的离散程度，即将全部数据从小到大排列，正好排列在上1/4位置叫上四分位数，下1/4位置上的数就叫做下四分位数。下面的R程序计算数据集（1，2，3，4，5，6，7，8，9）的四分位数。

> S<-c（1，2，3，4，5，6，7，8，9）
> quantile（S） # 四分位数
0% 25% 50% 75% 100%
1 3 5 7 9
> fivenum（S） # 5个分位值
[1] 1 3 5 7 9

R中也有通用的统计计算函数summary（）。在R语言中，summary（）函数对上面的几个常用统计量进行了封装，直接把数据集传入summary（）函数，可以很方便地看到计算结果。下面的R程序计算数据集（1，2，3，4，5，6，7，8，9）的统计函数。

> S<-c（1，2，3，4，5，6，7，8，9）
> summary（S） # 统计函数
Min. 1st Qu. Median Mean 3rd Qu. Max.
1 3 5 5 7 9

5.协方差

协方差（covariance）用于衡量两个变量的总体误差。而方差是协方差的一种特殊情况，即当两个变量是相同的情况。设X，Y为两个随机变量，称E{[X-E（X）][Y-E（Y）]}为X和Y的协方差，记为Cov（X，Y），如公式（1.4）所示。

下面的R程序计算X（1，2，3，4）和Y（5，6，7，8）的协方差。

> X<-c（1，2，3，4）
> Y<-c（5，6，7，8）
> cov（X，Y） # 协方差
[1] 1.666667

6.相关系数

相关系数（correlation coefficient）是用来反映变量之间相关关系密切程度的统计指标。相关系数是按积差方法计算，同样以两变量与各自平均值的离差为基础，通过两个离差相乘来反映两变量之间的相关程度。当Var（X）>0，Var（Y）>0时，称为X与Y的相关系数，如公式（1.5）所示。

下面的R程序计算X（1，2，3，4）和Y（5，7，8，9）的相关系数。

> X<-c（1，2，3，4）
> Y<-c（5，7，8，9）
> cor（X，Y） # 相关系数
[1] 0.9827076

7.矩

矩是广泛应用的一类数学特征，均值和方差分别就是一阶原点矩和二阶中心矩。

原点矩（moment about origin）：对于正整数k，如果E（Xk）存在，称ak=E（Xk）为随机变量X的k阶原点矩。X的数学期望是X的一阶原点矩，即E（X），如公式（1.6）所示。

下面的R程序计算S（1，2，3，4，5）的一阶原点矩（均值）。

> S<-c（1，2，3，4，5）
> mean（S） # 一阶原点矩
[1] 3

中心矩（moment about centre）：对于正整数k，如果E（X）存在，且E（[X-E（X）]k）也存在，则称E[X-E（X）]k为随机变量X的k阶中心矩。X的方差是X的二阶中心矩，即E（[X-E（X）]k），如公式（1.7）所示。

下面的R程序计算S（1，2，3，4，5）的二阶中心矩（方差）。

> S<-c（1，2，3，4，5）
> var（S） # 二阶中心矩
[1] 2.5

偏度（skewness）是统计数据分布偏斜方向和程度的度量，是统计数据分布非对称程度的数字特征。设分布函数F（x）有中心矩μ_2=E（X-E（X））2，μ_3=E（X-E（X））3，则Cs=μ_3/μ_2^（3/2）为偏度系数，如公式（1.8）所示。

当Cs>0时，概率分布偏向均值右侧；当Cs<0时，概率分布偏向均值左侧。

下面的R程序计算10000个正态分布的数据集的偏度。

> library（PerformanceAnalytics） # 加载PerformanceAnalytics包
> S<-rnorm（10000） # 取10000个正态分布随机变量的样本点
> skewness（S） # 计算偏度
[1] -0.00178084
> hist（S，breaks=100） # 画出正态分布的柱状图，如图1-10所示

图1-10　10000个正态分布变量样本点的柱状图

峰度（kurtosis）又称峰态系数，表征概率密度分布曲线在平均值处峰值高低的特征数。峰度刻划不同类型的分布的集中和分散程序。设分布函数F（x）有中心矩μ_2=E（X-E（X））2，μ_4=E（X-E（X））4，则为峰度系数，如公式（1.9）所示。

R语言计算正态分布的一个大小为10000的样本（同偏度的样本数据）的峰度：

> kurtosis（S） # 计算峰度
[1] -0.02443549

8.协方差矩阵

协方差矩阵（covariance matrix）是一个矩阵，它的每个元素是各个向量元素之间的协方差，这是从一维随机变量到多维随机向量的自然推广。设X=（X_1，X_2，…，Xn），Y=（Y_1，Y_2，…，Ym）为两个随机变量，则Cov（X，Y）为X，Y的协方差矩阵，如公式（1.10）所示。

R语言计算协方差矩阵如下。

> x=as.data.frame（matrix（rnorm（10），ncol=2））
> x
V1 V2
1 -2.11315384 -2.55189840
2 -0.96631271 -1.36148355
3 -0.02835058 -0.82328774
4 -1.86669567 -0.07201353
5 0.27324957 -2.23835218
> cov（x） # 协方差矩阵
V1 V2
V1 1.13470650 -0.09292042
V2 -0.09292042 1.03172261

1.3.3　极限定理

1.大数定律

大数定律（law of large numbers）又称大数定理，是判断随机变量的算术平均值是否向常数收敛的定律，是概率论和数理统计学的基本定律之一。

设X_1，X_2，…，Xk是随机变量序列且E（Xk）存在（k=1，2，3，…），令Yn=（X_1+X_2+…+Xk）/n，若对于任意给定的ε>0，有公式（1.11）成立，

则称随机变量序列{Xk}服从大数定律。

作为上述定理的特殊情况，利用Chebyshev不等式，设随机变量X具有数学期望E（X）=μ，方差Var（X）=σ^2，则对于任意ε>0，如公式1.12所示。

假设投掷一枚硬币，得到正面的概率是0.5，投4次时，计算得到2次正面的概率？根据大数定律，如果投10000次，计算得到5000次正面的概率？

计算2次正面的概率：

> choose（4，2）/2^4 # choose组合数的计算：从4中选择2个
[1] 0.375

计算5000次正面的概率：

> pbinom（5000， 10000， 0.5） # pbinom二向分布，5000为分位数，产生10000个随机数，每个概率0.5
[1] 0.5039893

2.中心极限定理

中心极限定理（central limit theorem）是判断随机变量序列部分和的分布是否渐近于正态分布的一类定理。在自然界及生产科学实践中，一些现象受到许多相互独立的随机因素的影响，如果每个因素的影响都很小，那么总的影响可以看做是服从正态分布。中心极限定理正是从数学上论证了这一现象。设从均值为μ、方差为σ^2（有限）的任意一个总体中抽取样本量为n的样本，则当n充分大时，样本均值的抽样分布近似服从均值为μ、方差为σ^2/n的正态分布。两个最著名的中心极限定理是列维（Levy）定理和拉普拉斯（Laplace）定理。

列维定理即独立同分布随机变量序列的中心极限定理。它表明，独立同分布且数学期望和方差有限的随机变量序列的标准化和以标准正态分布为极限。

设随机变量X_1，X_2，…Xn，…相互独立，服从同一分布，且具有数学期望和方差：E（Xk）=μ，D（Xk）=σ^2>0（k=1，2，…），则随机变量之和的标准化变量的分布函数Fn（x）对于任意x满足，其中Φ（x）是标准正态分布的分布函数。

拉普拉斯定理即服从二项分布的随机变量序列的中心极限定理。它指出，参数为n，p的二项分布以np为均值、np（1-p）为方差的正态分布为极限。

图1-11　中心极限定理动画模拟

R程序的中心极限定理动画模拟（从指数分布到正态分布）如图1-11所示。代码摘自animation包帮助文档。

> if （！require（animation）） install.packages（"animation"）
> library（animation）
> ani.options（interval = 0.1， nmax = 100）
> par（mar = c（4， 4， 1， 0.5））
> clt.ani（）

掌握R语言，就可以方便地运用概率的知识进行各种概率计算，非常有利于帮助我们解决生活中遇到的问题。

1.4　常用连续型分布介绍及R语言实现

问题

如何让R语言画出概率分布函数曲线？

引言

随机变量在我们的生活中处处可见，如每日天气、股价涨跌、彩票中奖等，这些事情都是事前不可预言其结果的，就算在相同的条件下重复进行试验，其结果未必相同。数学家们总结了这种规律，用概率分布来描述随机变量取值。就算股价不能预测，但如果知道了它的波动率的概率分布，那么我们就会有更大的机会猜出答案。

本节将介绍用R语言画出多种连续型概率分布的曲线，包括正态分布、指数分布、伽玛分布、韦布尔分布、F分布、T分布、贝塔分布、卡方分布、均匀分布。

1.4.1　均匀分布

本节的系统环境是：

·Windows 7 64bit

·R：3.1.1 x86_64-w64-mingw32/x64（64-bit）

均匀分布（uniform distribution）是均匀的、不偏差的一种简单的概率分布，分为离散型均匀分布与连续型均匀分布，本节只介绍连续型的概率分布部分。

1.概率密度函数

均匀分布的概率密度函数由式（1.13）给出。

下面的R程序画出均匀分布的概率密度函数曲线：

> set.seed（1） # 设置随机种子
> x<-seq（0，10，length.out=1000） # 取从0~10顺序取的1000个点
> y<-dunif（x，0，1） # 计算服从均匀分布U（0，1），1000个点的概率密度函数的值
> plot（x，y，col="red"，xlim=c（0，10），ylim=c（0，1.2），type='l'，xaxs="i"， yaxs="i"，
ylab='density'，xlab=''，main="The Uniform Density Distribution"）
# 画出概率密度函数曲线，如图1-12所示
> lines（x，dnorm（x，0，0.5），col="green"） # 计算服从均匀分布U（0，0.5）的值，并增加一条曲线
> lines（x，dnorm（x，0，2），col="blue"） # 计算服从均匀分布U（0，2）的值，并增加一条曲线
> lines（x，dnorm（x，-2，1），col="orange"） # 计算服从均匀分布U（-2，1）的值，并增加一条曲线
> lines（x，dnorm（x，4，2），col="purple"） # 计算服从均匀分布U（4，2）的值，并增加一条曲线
> legend（"topright"，legend=paste（"m="，c（0，0，0，-2，4），" sd="， c（1，0.5，2，1，2）），
lwd=1， col=c（"red"， "green"，"blue"，"orange"，"purple"）） # 在右上角增加图例

图1-12　均匀分布的概率密度函数图

图1-13　均匀分布的累积分布函数图

2.累积分布函数

均匀分布的累积分布函数公式为（1.14）：

下面的R程序画出均匀分布的累积分布函数曲线：

> set.seed（1） # 设置随机种子
> x<-seq（0，10，length.out=1000） # 取从0~10顺序取的1000个点
> y<-punif（x，0，1） # 计算服从均匀分布U（0，1），1000个点的累积分布函数的值
> plot（x，y，col="red"，xlim=c（0，10），ylim=c（0，1.2），type='l'，xaxs="i"， yaxs="i"，
ylab='F（x）'，xlab=''，main="The Uniform Cumulative Distribution Function"）
# 画出累积分布函数的曲线，如图1-13所示
> lines（x，punif（x，0，0.5），col="green"）
> lines（x，punif（x，0，2），col="blue"）
> lines（x，punif（x，-2，1），col="orange"）
> legend（"bottomright"，legend=paste（"m="，c（0，0，0，-2），" sd="， c（1，0.5，2，1）），
lwd=1， col=c（"red"， "green"，"blue"，"orange"，"purple"））

3.分布检验

Kolmogorov-Smirnov连续分布检验是检验单一样本是不是服从某一预先假设的特定分布的方法。把样本数据的累计频数分布与特定理论分布相比较，若两者间的差距很小，则推论该样本取自某特定分布族。

均匀分布检验的原假设为H_0：数据集符合均匀分布，备择假设为H_1：样本所来自的总体分布不符合均匀分布。令F_0（x）表示预先假设的理论分布，Fn（x）表示随机样本的累计概率（频率）函数。统计量D为：

·D值越小，越接近0，表示样本数据越接近均匀分布

·p值，如果p值小于显著性水平α（0.05），则拒绝H_0

> set.seed（1） # 设置随机种子
> S<-runif（1000） # 生成服从均匀分布的1000点
> ks.test（S， "punif"） # Kolmogorov-Smirnov检验
One-sample Kolmogorov-Smirnov test
data： S
D = 0.0244， p-value = 0.5928
alternative hypothesis： two-sided

D值很小，p值>0.05，不能拒绝原假设，所以数据集S符合均匀分布！

后文中其他函数的分布检验也使用的是Kolmogorov-Smirnov的检验方法，因此后面检验描述从略。

1.4.2　正态分布

正态分布（normal distribution）又名高斯分布（Gaussian distribution），是一个在数学、物理及工程等领域都非常重要的概率分布，在统计学的许多方面有着重大的影响力。

若随机变量X服从一个位置参数为μ、尺度参数为σ^2的高斯分布，则这个随机变量就称为正态随机变量，正态随机变量服从的分布就称为正态分布，记为N（μ，σ^2）。数学期望μ决定了分布位置，标准差σ决定了分布的幅度。因其曲线呈钟形，因此人们又经常称之为钟形曲线。我们通常所说的标准正态分布是μ=0，σ=1的正态分布。

1.概率密度函数

正态分布的概率密度函数公式为（1.15）：

下面的R程序画出正态分布的概率密度函数曲线：

> set.seed（1）
> x <- seq（-5，5，length.out=100） # 取从-5到5的100个点
> y <- dnorm（x，0，1） # 计算服从正态分布N（0，1），100个点的概率密度函数的值
> plot（x，y，col="red"，xlim=c（-5，5），ylim=c（0，1），type='l'，xaxs="i"， yaxs="i"，ylab
='density'，xlab=''，main="The Normal Density Distribution"）
# 画出概率密度函数曲线，如图1-14所示
> lines（x，dnorm（x，0，0.5），col="green"）
> lines（x，dnorm（x，0，2），col="blue"）
> lines（x，dnorm（x，-2，1），col="orange"）
> legend（"topright"，legend=paste（"m="，c（0，0，0，-2），" sd="， c（1，0.5，2，1））， lwd=1，
col=c（"red"， "green"，"blue"，"orange"））

图1-14　正态分布的概率密度函数图

图1-15　正态分布的概率密度函数图

2.累积分布函数

正态分布的概率密度函数公式为（1.16）：

下面的R程序画出正态分布的累积分布函数曲线：

> set.seed（1）
> x <- seq（-5，5，length.out=100）
> y <- pnorm（x，0，1） # 计算服从正态分布N（0，1），100个点的累积分布函数的值
> plot（x，y，col="red"，xlim=c（-5，5），ylim=c（0，1），type='l'，xaxs="i"， yaxs="i"，
ylab='F（x）'，xlab=''，main="The Normal Cumulative Distribution"）
# 画出累积分布函数曲线，如图1-15所示
> lines（x，pnorm（x，0，0.5），col="green"）
> lines（x，pnorm（x，0，2），col="blue"）
> lines（x，pnorm（x，-2，1），col="orange"）
> legend（"bottomright"，legend=paste（"m="，c（0，0，0，-2），" sd="， c（1，0.5，2，1）），
lwd=1，col=c（"red"， "green"，"blue"，"orange"））

3.分布检验

Shapiro-Wilk正态分布检验用来检验数据是否符合正态分布，同线性回归的方法一样，是检验其与回归曲线的残差。该方法推荐在样本量很小的时候使用，一般是样本在3~5000之间。

Shapiro-Wilk正态分布检验的原假设为H_0：数据集符合正态分布，统计量W为

其中统计量W最大值是1，越接近1，表示样本与正态分布越匹配。如果p值小于显著性水平α（0.05），则拒绝H_0

> set.seed（1）
> S<-rnorm（1000） # 生成服从正态分布的1000点
> shapiro.test（S） # Shapiro-Wilk正态分布检验
Shapiro-Wilk normality test
data： S
W = 0.9988， p-value = 0.7256

这里W接近1，p值>0.05，不能拒绝原假设，所以数据集S符合正态分布！

若用Kolmogorov-Smirnov连续分布检验，原假设为H_0：数据集符合正态分布，备择假设为H_1：样本所来自的总体分布不符合正态分布。

> set.seed（1）
> S<-rnorm（1000）
> ks.test（S， "pnorm"） # Kolmogorov-Smirnov检验
One-sample Kolmogorov-Smirnov test
data： S
D = 0.0211， p-value = 0.7673
alternative hypothesis： two-sided

这里D值很小，p值>0.05，不能拒绝原假设，所以数据集S符合正态分布！

1.4.3　指数分布

指数分布（exponential distribution）用来表示独立随机事件发生的时间间隔，比如旅客进机场的时间间隔、中文维基百科新条目出现的时间间隔等。许多电子产品的寿命一般服从指数分布，有的系统的寿命分布也可用指数分布来近似。当产品的失效是偶然失效时，其寿命服从指数分布。指数分布的失效率是与时间t无关的常数，所以分布函数简单。指数分布在可靠性研究中是最常用的一种分布形式。

1.概率密度函数

指数分布的概率密度函数公式为（1.18）：

其中λ>0是分布的参数，常被称为率参数（rate parameter），即每单位时间发生该事件的次数。指数分布的取值区间是[0，∞）。如果一个随机变量X呈指数分布，则可以写作X~Exponential（λ）。

下面的R程序画出指数分布的概率密度函数曲线。

> set.seed（1）
> x<-seq（-1，2，length.out=100）
> y<-dexp（x，0.5） # 计算服从指数分布e（0.5），100个点的概率密度函数的值
> plot（x，y，col="red"，xlim=c（0，2），ylim=c（0，5），type='l'，xaxs="i"， yaxs="i"，ylab=
'density'，xlab=''，main="The Exponential Density Distribution"）
# 画出概率密度函数曲线，如图1-16所示
> lines（x，dexp（x，1），col="green"）
> lines（x，dexp（x，2），col="blue"）
> lines（x，dexp（x，5），col="orange"）
> legend（"topright"，legend=paste（"rate="，c（.5， 1， 2，5））， lwd=1，col=c（"red"，
"green"，"blue"，"orange"））

图1-16　指数分布的概率密度函数图

图1-17　指数分布的累积分布函数图

2.累积分布函数

指数分布的累积分布函数公式为（1.19）：

下面的R程序画出指数分布的累积分布函数曲线。

> set.seed（1）
> x<-seq（-1，2，length.out=100）
> y<-pexp（x，0.5） # 计算服从指数分布e（0.5），100个点的累积分布函数的值
> plot（x，y，col="red"，xlim=c（0，2），ylim=c（0，1），type='l'，xaxs="i"， yaxs="i"，ylab=
'F（x）'，xlab=''，main="The Exponential Cumulative Distribution Function"）
# 画出累积分布函数曲线，如图1-17所示
> lines（x，pexp（x，1），col="green"）
> lines（x，pexp（x，2），col="blue"）
> lines（x，pexp（x，5），col="orange"）
> legend（"bottomright"，legend=paste（"rate="，c（.5， 1， 2，5））， lwd=1， col=c（"red"，
"green"，"blue"，"orange"））

3.分布检验

对指数分布来说，Kolmogorov-Smirnov连续分布检验的原假设为H_0：数据集符合指数分布，备择假设为H_1：样本所来自的总体分布不符合指数分布。

> set.seed（1）
> S<-rexp（1000）
> ks.test（S， "pexp"） # Kolmogorov-Smirnov检验
One-sample Kolmogorov-Smirnov test
data： S
D = 0.0387， p-value = 0.1001
alternative hypothesis： two-sided

这里，D值很小，p值>0.05，不能拒绝原假设，所以数据集S符合指数分布！

1.4.4　伽玛分布

伽玛分布（Gamma）是著名的皮尔逊概率分布函数簇中重要的一员，称为皮尔逊Ⅲ型分布。它的曲线有一个峰，但左右不对称。伽玛函数是阶乘在实数上的泛化，其公式为（1.20）：

1.概率密度函数

伽玛分布的概率密度函数公式为（1.21）：

其中k为形状参数，θ为尺度参数。

下面的R程序画出伽玛分布的概率密度函数曲线。

> set.seed（1）
> x<-seq（0，10，length.out=100）
> y<-dgamma（x，1，2） # 计算服从伽玛分布Ga（1，2），100个点的概率密度函数的值
> plot（x，y，col="red"，xlim=c（0，10），ylim=c（0，2），type='l'，xaxs="i"， yaxs="i"，ylab=
'density'，xlab=''，main="The Gamma Density Distribution"）
# 画出概率密度函数曲线，如图1-18所示
> lines（x，dgamma（x，2，2），col="green"）
> lines（x，dgamma（x，3，2），col="blue"）
> lines（x，dgamma（x，5，1），col="orange"）
> lines（x，dgamma（x，9，1），col="black"）
> legend（"topright"，legend=paste（"shape="，c（1，2，3，5，9），" rate="， c（2，2，2，1，1）），
lwd=1， col=c（"red"， "green"，"blue"，"orange"，"black"））

2.累积分布函数

伽玛分布的累积分布函数公式为（1.22）：

下面的R程序画出伽玛分布的累积分布函数曲线。

> set.seed（1）
> x<-seq（0，10，length.out=100）
> y<-pgamma（x，1，2） # 计算服从伽玛分布Ga（1，2），100个点的累积分布函数的值
> plot（x，y，col="red"，xlim=c（0，10），ylim=c（0，1），type='l'，xaxs="i"， yaxs="i"，ylab=
'F（x）'，xlab=''，main="The Gamma Cumulative Distribution Function"）
# 画出累积分布函数曲线，如图1-19所示
> lines（x，pgamma（x，2，2），col="green"）
> lines（x，pgamma（x，3，2），col="blue"）
> lines（x，pgamma（x，5，1），col="orange"）
> lines（x，pgamma（x，9，1），col="black"）
> legend（"bottomright"，legend=paste（"shape="，c（1，2，3，5，9），" rate="，
c（2，2，2，1，1））， lwd=1， col=c（"red"， "green"，"blue"，"orange"，"black"））

图1-18　伽玛分布的概率密度函数图

图1-19　伽玛分布的累积分布函数图

3.分布检验

对伽玛分布来说，Kolmogorov-Smirnov连续分布检验的原假设为H_0：数据集符合伽玛分布，备择假设为H_1：样本所来自的总体分布不符合伽玛分布。

> set.seed（1）
> S<-rgamma（1000，1）
> ks.test（S， "pgamma"， 1） # Kolmogorov-Smirnov检验
One-sample Kolmogorov-Smirnov test
data： S
D = 0.0363， p-value = 0.1438
alternative hypothesis： two-sided

这里D值很小，p值>0.05，不能拒绝原假设，所以数据集S符合形状参数为1伽玛分布！

下面我们做一个检验失败的测试，如果设检验形状参数为2，那么用Kolmogorov-Smirnov检验时，结果就不是符合我们预期的。

> ks.test（S， "pgamma"， 2） # Kolmogorov-Smirnov检验
One-sample Kolmogorov-Smirnov test
data： S
D = 0.3801， p-value < 2.2e-16
alternative hypothesis： two-sided

这里D值不够小，p值<0.05，拒绝原假设，所以数据集S不符合形状参数为2伽玛分布！

1.4.5　韦布尔分布

韦布尔（Weibul）分布，又称韦氏分布或韦伯分布，是可靠性分析和寿命检验的理论基础。韦布尔分布由形状、尺度（范围）和位置三个参数决定，其中形状参数是最重要的参数，决定分布密度曲线的基本形状，尺度参数起放大或缩小曲线的作用，但不影响分布的形状。

韦布尔分布通常用在故障分析领域中；尤其是它可以模拟故障率（failture rate）持续变化的分布。如果故障率：

·一直为常量（constant over time），那么α=1，暗示在随机事件中发生；

·一直减少（decreases over time），那么α<1，暗示“早期失效（infant mortality）”；

·一直增加（increases over time），那么α>1，暗示“耗尽（wear out）”，即随着时间的推进，失败的可能性变大。

1.概率密度函数

韦布尔分布的概率密度函数公式为（1.23）：

下面的R程序画出韦布尔分布的概率密度函数曲线。

> set.seed（1）
> x<- seq（0， 2.5， length.out=1000）
> y<- dweibull（x， 0.5） # 计算服从韦布尔分布W（0.5，1），1000个点的概率密度函数的值
> plot（x， y， type="l"， col="blue"，xlim=c（0， 2.5），ylim=c（0， 6），xaxs="i"， yaxs=
"i"，ylab='density'，xlab=''，main="The Weibull Density Distribution"）
# 画出概率密度函数曲线，如图1-20所示
> lines（x， dweibull（x， 1）， type="l"， col="red"）
> lines（x， dweibull（x， 1.5）， type="l"， col="magenta"）
> lines（x， dweibull（x， 5）， type="l"， col="green"）
> lines（x， dweibull（x， 15）， type="l"， col="purple"）
> legend（"topright"， legend=paste（"shape ="， c（.5， 1， 1.5， 5， 15）），
lwd=1，col=c（"blue"， "red"， "magenta"， "green"，"purple"））

2.累积分布函数

韦布尔分布的累积分布函数公式为（1.24）：

下面的R程序画出韦布尔分布的累积分布函数曲线。

> set.seed（1）
> x<- seq（0， 2.5， length.out=1000）
> y<- pweibull（x， 0.5） # 计算服从weibull分布W（0.5，1），1000个点的累积分布函数的值
> plot（x， y， type="l"， col="blue"，xlim=c（0， 2.5），ylim=c（0， 1.2），xaxs="i"， yaxs=
"i"，ylab='F（x）'，xlab=''，main="The Weibull Cumulative Distribution Function"）
# 画出累积分布函数曲线，如图1-21所示
> lines（x， pweibull（x， 1）， type="l"， col="red"）
> lines（x， pweibull（x， 1.5）， type="l"， col="magenta"）
> lines（x， pweibull（x， 5）， type="l"， col="green"）
> lines（x， pweibull（x， 15）， type="l"， col="purple"）
> legend（"bottomright"， legend=paste（"shape ="， c（.5， 1， 1.5， 5， 15））， lwd=1，
col=c（"blue"， "red"， "magenta"， "green"，"purple"））

图1-20　韦布尔分布的概率密度函数图

图1-21　韦布尔分布的累积分布函数图

3.分布检验

对于韦布尔分布，Kolmogorov-Smirnov连续分布检验的原假设为H_0：数据集符合韦布尔分布，备择假设为H_1：样本所来自的总体分布不符合韦布尔分布。

> set.seed（1）
> S<-rweibull（1000，1）
> ks.test（S， "pweibull"，1） # Kolmogorov-Smirnov检验
One-sample Kolmogorov-Smirnov test
data： S
D = 0.0244， p-value = 0.5928
alternative hypothesis： two-sided

这里D值很小，p值>0.05，不能拒绝原假设，所以数据集S符合形状参数为1的韦布尔分布！

1.4.6　卡方分布

若n个相互独立的随机变量ξ_1，ξ_2，…，ξn均服从标准正态分布（也称独立同分布于标准正态分布），则这n个服从标准正态分布的随机变量的平方和构成一个新的随机变量，其分布规律称为卡方（χ^2，chi-square）分布。其中参数n称为自由度，自由度不同就是另一个卡方分布，正如正态分布中均值或方差不同就是另一个正态分布一样。

1.概率密度函数

卡方分布的概率密度函数公式为（1.25）：

其中分母Γ是伽玛函数。

下面是R程序画出卡方分布的概率密度函数曲线。

> set.seed（1）
> x<-seq（0，10，length.out=1000）
> y<-dchisq（x，1） # 计算服从卡方分布X（1），1000个点的概率密度函数的值
> plot（x，y，col="red"，xlim=c（0，5），ylim=c（0，2），type='l'，xaxs="i"， yaxs="i"，ylab=
'density'，xlab=''，main="The Chisq Density Distribution"）
# 画出概率密度函数曲线，如图1-22所示
> lines（x，dchisq（x，2），col="green"）
> lines（x，dchisq（x，3），col="blue"）
> lines（x，dchisq（x，10），col="orange"）
> legend（"topright"，legend=paste（"df="，c（1，2，3，10））， lwd=1， col=c（"red"，
"green"，"blue"，"orange"））

2.累积分布函数

卡方分布的累积分布函数公式为（1.26）：

其中分母Γ是伽玛函数，分子γ（k，z）为不完全伽玛函数。

下面的R程序画出卡方分布的累积分布函数曲线。

> set.seed（1）
> x<-seq（0，10，length.out=1000）
> y<-pchisq（x，1） # 计算服从卡方分布X（1），1000个点的累积分布函数的值
> plot（x，y，col="red"，xlim=c（0，10），ylim=c（0，1），type='l'，xaxs="i"， yaxs="i"，ylab=
'F（x）'，xlab=''，main="The Chisq Cumulative Distribution Function"）
# 画出累积分布函数曲线，如图1-23所示
> lines（x，pchisq（x，2），col="green"）
> lines（x，pchisq（x，3），col="blue"）
> lines（x，pchisq（x，10），col="orange"）
> legend（"topleft"，legend=paste（"df="，c（1，2，3，10））， lwd=1， col=c（"red"， "green"，
"blue"，"orange"））

图1-22　卡方分布的概率密度函数图

图1-23　卡方分布的累积分布函数图

3.分布检验

对于卡方分布，Kolmogorov-Smirnov连续分布检验的原假设为H_0：数据集符合卡方分布，备择假设为H_1：样本所来自的总体分布不符合卡方分布。

> set.seed（1）
> S<-rchisq（1000，1）
> ks.test（S， "pchisq"，1） # Kolmogorov-Smirnov检验
One-sample Kolmogorov-Smirnov test
data： S
D = 0.0254， p-value = 0.5385
alternative hypothesis： two-sided

这里D值很小，p值>0.05，不能拒绝原假设，所以数据集S符合自由度为1的卡方分布！

1.4.7　F分布

F分布是一种连续型概率分布，广泛应用于似然比率检验，特别是ANOVA中。F分布的定义为：设X，Y为两个独立的随机变量，X服从自由度为d_1的卡方分布，Y服从自由度为d_2的卡方分布，则服从自由度为d_1和d_2的F分布。

F分布是一种非对称分布，它有两个自由度，即d_1和d_2，相应的分布记为F（d_1，d_2），d_1通常称为分子自由度，d_2通常称为分母自由度。F分布是一个以自由度d_1和d_2为参数的分布族，不同的自由度决定了F分布的形状。

1.概率密度函数

F分布的概率密度函数公式为（1.27）：

其中Γ是伽玛函数。

下面的R程序画出F分布的概率密度函数曲线。

> set.seed（1）
> x<-seq（0，5，length.out=1000）
> y<-df（x，1，1，0） # 计算服从F分布F（1，1，0），1000个点的概率密度函数的值
> plot（x，y，col="red"，xlim=c（0，5），ylim=c（0，1），type='l'，xaxs="i"， yaxs="i"，ylab=
'density'，xlab=''，main="The F Density Distribution"）
# 画出概率密度函数曲线，如图1-24所示
> lines（x，df（x，1，1，2），col="green"）
> lines（x，df（x，2，2，2），col="blue"）
> lines（x，df（x，2，4，4），col="orange"）
> legend（"topright"，legend=paste（"df1="，c（1，1，2，2），"df2="，c（1，1，2，4），" ncp="，
c（0，2，2，4））， lwd=1， col=c（"red"， "green"，"blue"，"orange"））

2.累积分布函数

F分布的累积分布函数公式为（1.28）：

其中I是不完全Beta函数

下面的R程序画出F分布的累积分布函数曲线。

> set.seed（1）
> x<-seq（0，5，length.out=1000）
> y<-df（x，1，1，0） # 计算服从F分布F（1，1，0），1000个点的累积分布函数的值
> plot（x，y，col="red"，xlim=c（0，5），ylim=c（0，1），type='l'，xaxs="i"， yaxs="i"，ylab=
'F（x）'，xlab=''，main="The F Cumulative Distribution Function"）
# 画出累积分布函数曲线，如图1-25所示
> lines（x，pf（x，1，1，2），col="green"）
> lines（x，pf（x，2，2，2），col="blue"）
> lines（x，pf（x，2，4，4），col="orange"）
> legend（"topright"，legend=paste（"df1="，c（1，1，2，2），"df2="，c（1，1，2，4），" ncp="，
c（0，2，2，4））， lwd=1， col=c（"red"， "green"，"blue"，"orange"））

图1-24　F分布的概率密度函数图

图1-25　F分布的累积分布函数图

3.分布检验

对于F分布，Kolmogorov-Smirnov连续分布检验的原假设为H_0：数据集符合F分布，备择假设为H_1：样本所来自的总体分布不符合F分布。

> set.seed（1）
> S<-rf（1000，1，1，2）
> ks.test（S， "pf"， 1，1，2） # Kolmogorov-Smirnov检验
One-sample Kolmogorov-Smirnov test
data： S
D = 0.0113， p-value = 0.9996
alternative hypothesis： two-sided

这里D值很小，p值>0.05，不能拒绝原假设，所以数据集S符合df1=1，df2=1，ncp=2的F分布！

1.4.8　t分布

学生t分布（Student’s t-Distribution），可简称为t分布，应用于估计呈正态分布的总体之平均数。它是对两个样本均值差异进行显著性测试的学生t检验的基础。学生t检验改进了Z检验（Z-test），因为Z检验以总体标准差已知为前提。虽然在样本数量大（超过30个）时，可以应用Z检验来求得近似值，但Z检验用在小样本会产生很大的误差，因此必须改用学生t检验以求准确。

1.概率密度函数
t分布的概率密度函数公式为

其中ν等于n-1，一般称为自由度；Γ是伽玛函数。

下面的R程序画出t分布的概率密度函数曲线。

> set.seed（1）
> x<-seq（-5，5，length.out=1000）
> y<-dt（x，1，0） # 计算服从t分布T（1，0），1000个点的概率密度函数的值
> plot（x，y，col="red"，xlim=c（-5，5），ylim=c（0，0.5），type='l'，xaxs="i"， yaxs="i"，ylab
='density'，xlab=''，main="The T Density Distribution"）
# 画出概率密度函数曲线，如图1-26所示
> lines（x，dt（x，5，0），col="green"）
> lines（x，dt（x，5，2），col="blue"）
> lines（x，dt（x，50，4），col="orange"）
> legend（"topleft"，legend=paste（"df="，c（1，5，5，50），" ncp="， c（0，0，2，4））， lwd=1，
col=c（"red"， "green"，"blue"，"orange"））

2.累积分布函数
t分布的累积分布函数公式为（1.30）：

其中ν等于n-1，一般称为自由度；Γ是伽玛函数。

下面的R程序画出t分布的累积分布函数曲线。

> set.seed（1）
> x<-seq（-5，5，length.out=1000）
> y<-pt（x，1，0） # 计算服从T分布T（1，0），1000个点的累积分布函数的值
> plot（x，y，col="red"，xlim=c（-5，5），ylim=c（0，0.5），type='l'，xaxs="i"， yaxs="i"，ylab
='F（x）'，xlab=''，main="The T Cumulative Distribution Function"）
# 画出累积分布函数曲线，如图1-27所示
> lines（x，pt（x，5，0），col="green"）
> lines（x，pt（x，5，2），col="blue"）
> lines（x，pt（x，50，4），col="orange"）
> legend（"topleft"，legend=paste（"df="，c（1，5，5，50），" ncp="， c（0，0，2，4））， lwd=1，
col=c（"red"， "green"，"blue"，"orange"））

图1-26　t分布的概率密度函数图

图1-27　t分布的累积分布函数图

3.分布检验

对于t分布，Kolmogorov-Smirnov连续分布检验的原假设为H_0：数据集符合t分布，备择假设为H_1：样本所来自的总体分布不符合t分布。

> set.seed（1）
> S<-rt（1000， 1，2）
> ks.test（S， "pt"， 1， 2） # Kolmogorov-Smirnov检验
One-sample Kolmogorov-Smirnov test
data： S
D = 0.0253， p-value = 0.5461
alternative hypothesis： two-sided

这里D值很小，p值>0.05，不能拒绝原假设，所以数据集S符合df=1，ncp=2的t分布！

1.4.9　贝塔分布

贝塔（Beta）分布是指一组定义在（0，1）区间的连续概率分布，Beta分布有α和β两个参数，α，β>0，其中α为成功次数加1，β为失败次数加1。

贝塔分布通常用来为取值于某有限区间[c，d]的随机现象建立模型。当然，如果令c为原点，而d-c为单位长度，那么可将取值区间转化为[0，1]。贝塔分布的一个重要应用是作为伯努利分布和二项式分布的共轭先验分布出现，在机器学习和数理统计学中有重要应用。

1.概率密度函数

概率密度函数公式为（1.31）：

其中随机变量X服从参数为α，β的贝塔分布，Γ是伽玛函数

下面的R程序画出贝塔分布的概率密度函数曲线。

> set.seed（1）
> x<-seq（-5，5，length.out=10000）
> y<-dbeta（x，0.5，0.5） # 计算服从贝塔分布B（0.5，0.5），10000个点的概率密度函数的值
> plot（x，y，col="red"，xlim=c（0，1），ylim=c（0，6），type='l'，xaxs="i"， yaxs="i"，ylab=
'density'，xlab=''，main="The Beta Density Distribution"）
# 画出概率密度函数曲线，如图1-28所示
> lines（x，dbeta（x，5，1），col="green"）
> lines（x，dbeta（x，1，3），col="blue"）
> lines（x，dbeta（x，2，2），col="orange"）
> lines（x，dbeta（x，2，5），col="black"）
> legend（"top"，legend=paste（"a="，c（.5，5，1，2，2），" b="， c（.5，1，3，2，5））， lwd=1，
col=c（"red"， "green"，"blue"，"orange"，"black"））

2.累积分布函数

贝塔分布的累积分布函数公式为（1.32）：

其中B是正则不完全贝塔函数。

下面的R程序画出贝塔分布的累积分布函数曲线。

> set.seed（1）
> x<-seq（-5，5，length.out=10000）
> y<-pbeta（x，0.5，0.5） # 计算服从贝塔分布B（0.5，0.5），10000个点的累积分布函数的值
> plot（x，y，col="red"，xlim=c（0，1），ylim=c（0，1），type='l'，xaxs="i"， yaxs="i"，ylab=
'F（x）'，xlab=''，main="The Beta Cumulative Distribution Function"）
# 画出累积分布函数曲线，如图1-29所示
> lines（x，pbeta（x，5，1），col="green"）
> lines（x，pbeta（x，1，3），col="blue"）
> lines（x，pbeta（x，2，2），col="orange"）
> lines（x，pbeta（x，2，5），col="black"）
> legend（"topleft"，legend=paste（"a="，c（.5，5，1，2，2），" b="， c（.5，1，3，2，5））， lwd=1，
col=c（"red"， "green"，"blue"，"orange"，"black"））

图1-28　贝塔分布的概率密度函数图

图1-29　贝塔分布的累积分布函数图

3.分布检验

对于贝塔分布，Kolmogorov-Smirnov连续分布检验的原假设为H_0：数据集符合贝塔分布，备择假设为H_1：样本所来自的总体分布不符合贝塔分布。

> set.seed（1）
> S<-rbeta（1000，1，2）
> ks.test（S， "pbeta"，1，2） # Kolmogorov-Smirnov检验
One-sample Kolmogorov-Smirnov test
data： S
D = 0.0202， p-value = 0.807
alternative hypothesis： two-sided

这里D值很小，p值>0.05，不能拒绝原假设，所以数据集S符合形状参数为1和2的贝塔分布！

在掌握了这几种常用的连续型分布后，我们就可以基于这些分布来建模了，很多算法模型也就能解释通了！最后说明一点，本书不是统计学方面的教科书，对每种分布的定义均摘自互联网，与教科书有出入的部分请以统计学教科书为准。

1.5　R语言的导数计算

问题

如何用R语言进行导数计算？

引言

高等数学是每个大学生都要学习的一门数学基础课，同时也可能是考完试后最容易忘记的一门知识。我在学习高数的时候绞尽脑汁，但始终都不知道为何而学，生活和工作基本用不到，就算是在计算机行业和金融行业，能直接用到高数的地方也少之又少，学术和实际应用真是相差太远了。

不过，R语言为我打开了一扇高数应用的大门，R语言不仅能方便地实现高等数学的计算，还可以很容易地把一篇论文中的高数公式应用于产品的实践中。因为R语言我重新学习了高数，让生活中充满数学，生活会变得更有意思。本节并不是完整的高数计算手册，仅介绍了导数计算和偏导数计算的R语言实现。

1.5.1　导数计算

导数（derivative）是微分学的基本概念，其定义为，若函数y=f（x）在x_0的某个邻域内有定义，当自变量x在x_0处取得增加Δx（点x_0+Δx仍在该邻域内）时，相应的函数取得增量Δy=f（x_0+Δx）-f（x_0）；如果Δy与Δx之比当Δx趋于0时的极限存在，则称函数y=f（x）在点x_0处可导，并称这个极限为函数y=f（x）在点x_0处的导数，记为f'（x_0），即

也记作或。

通过R语言可以使用deriv（）函数直接进行导数的计算，比如要计算y=x^3的导数，根据导数计算公式，用于手动计算的变形结果为y'=3x^2，当x=1时，y'=3，当x=2时，y'=12。

本节的系统环境是：

·Windows 7 64bit

·R：3.1.1 x86_64-w64-mingw32/x64（64-bit）

用R语言程序实现导数计算，代码如下。

> dx <- deriv（y ~ x^3， "x"） ； dx # 生成导数公式
expression（{
.value <- x^3
.grad <- array（0， c（length（.value）， 1L）， list（NULL， c（"x"）））
.grad[， "x"] <- 3 * x^2
attr（.value， "gradient"） <- .grad
.value
}）
> mode（dx） # 查看dx变量类型
[1] "expression"
> x<-1：2 # 给自变量x赋值
> eval（dx） # 运行求导计算
[1] 1 8 # 原函数的计算结果
attr（，"gradient"） # 使用梯度下降法，导函数的计算结果
x
[1，] 3 # x=1，dx=3*1^2=3
[2，] 12 # x=2，dx=3*2^2=12

用R语言程序计算的结果，与我们手动计算的结果是一致的。但计算过程其实是有很大区别的，我们手动计算时是通过给定的导数计算公式，变形后完成计算。而用计算机程序计算时，是使用梯度下降法来计算一阶导数，是一种最优化的近似算法。对于手动计算导数时，如果函数比较复杂而且比较难应用可变形的公式，那么手动计算就会有非常大的困难，而计算机程序的方法是一般的导数计算方法，不会受到公式难于变形的影响。

我们使用deriv（expr，name）函数时通常要传2个参数，第一参数expr就是原函数公式，用~号来分隔公式的两边，第二参数name用于指定函数的自变量。deriv（）函数会返回一个表达式expression类型变量，再用eval（）函数运行这个表达式就可得到计算结果，如上面的代码实现。

如果希望以函数的形式调用计算公式，那么你还需要传第三个参数func，并让func参数为TRUE，参考下面的代码实现。

计算正弦函数y=sin（x）的导数，根据导数计算公式，用于手动计算的变形结果为y'=cos（x），当x=π时，y'=-1，当x=4π时，y'=1。

> dx <- deriv（y ~ sin（x）， "x"， func= TRUE） ； dx # 生成导数公式的调用函数
function （x）
{
.value <- sin（x）
.grad <- array（0， c（length（.value）， 1L）， list（NULL， c（"x"）））
.grad[， "x"] <- cos（x）
attr（.value， "gradient"） <- .grad
.value
}
> mode（dx） # 检查dx的类型
[1] "function"
> dx（c（pi，4*pi）） # 以参数作为自变量，进行函数调用
[1] 1.224606e-16 -4.898425e-16
attr（，"gradient"）
x # 导函数的计算结果
[1，] -1 # x=pi，dx=cos（pi）=-1
[2，] 1 # x=4*pi，dx=cos（4*pi）=1

1.5.2　初等函数的导数公式

对基本的初等函数求导数，通过导数计算公式是可以直接手动完成计算的。下面为一元初等函数的导数计算公式，其中y是原函数，x是y函数的自变量，y'是y函数的导函数。C，n，a为常数，ln表示以自然常数e为底的对数。

接下来，我们分别对这些一元初等函数进行一阶导数的计算。设y为原函数，x是y函数的自变量，且只有一个自变量。

1.常数函数

计算函数y=3+10x的导数，根据导数计算公式，用于手动计算的变形结果为y'=0+10x，常数项3的导数为0，当x=1时，y'=10。

> dx<-deriv（y~ 3+10*x，"x"，func = TRUE） # 以函数形式生成导数公式
> dx（1） # 传入自变量，并计算
[1] 13 # 原函数计算结果y=3+10*1=13
attr（，"gradient"）
x
[1，] 10 # 导函数计算结果y'=10*1=10

2.幂函数

计算y=x^4函数的导数，根据导数计算公式，用于手动计算的变形结果为y'=4x^3，当x=2时，y'=32。

> dx<-deriv（y~x^4，"x"，func = TRUE）
> dx（2）
[1] 16
attr（，"gradient"）
x
[1，] 32 # 导函数计算结果y'=4*x^3=4*2^3=32

3.指数函数

计算y=4x函数的导数，根据导数计算公式，用于手动计算的变形结果为y'=4xln（4），当x=2时，y'=22.18071。

0> dx<-deriv（y~4^x ，"x"，func = TRUE）
> dx（2）
[1] 16
attr（，"gradient"）
x
[1，] 22.18071 # 导函数计算结果y'=4^x*log（4）=4*2^3=22.18071

计算y=ex函数的导数，根据导数计算公式，用于手动计算的变形结果为y'=ex，当x=2时，y'=y=7.389056。

> dx<-deriv（y~exp（1）^x ，"x"，func = TRUE）
> dx（2）
[1] 7.389056
attr（，"gradient"）
x
[1，] 7.389056 # 导函数计算结果y'=exp（1）^x=exp（1）^2=7.389056

4.对数函数

计算y=ln（x）函数的导数，根据导数计算公式，用于手动计算的变形结果为y'=1/x，当x=2时，y'=0.5。

> dx<-deriv（y~log（x），"x"，func = TRUE）
> dx（2）
[1] 0.6931472
attr（，"gradient"）
x
[1，] 0.5 # 导函数计算结果y'=1/x=1/2=0.5

计算y=log_2x函数的导数，根据导数计算公式，用于手动计算的变形结果为y'=1/xlna，当x=3时，y'=0.4808983。但用R语言编程时，只能计算以自然常数为底的对数的导数，对于原函数不是以自然常数为底的对数，首先要变换成以自然常数为底的对数再进行导数计算，根据对数的换底公式，把以2为底的对数转换为以自然常数为底的对数y=log_2x=lnx/ln2，

> dx<-deriv（y~log（x）/log（2），"x"，func = TRUE）
> dx（3）
[1] 1.584963
attr（，"gradient"）
x
[1，] 0.4808983 # 导函数计算结果y'=1/（x*log（2）=1/（3*log（2）=0.4808983

5.正弦函数

计算y=sin（x）函数的导数，根据导数计算公式，用于手动计算的变形结果为y'=cos（x），当x=π时，y'=-1。

> dx<-deriv（y~sin（x），"x"，func = TRUE）
> dx（pi）
[1] 1.224606e-16
attr（，"gradient"）
x
[1，] -1 # 导函数计算结果y'=cos（x）=cos（pi）=-1

6.余弦函数

计算y=cos（x）函数的导数，根据导数计算公式，用于手动计算的变形结果为y'=-sin（x），当x=π/2时，y'=-1。

> dx<-deriv（y~cos（x），"x"，func = TRUE）
> dx（pi/2）
[1] 6.123032e-17
attr（，"gradient"）
x
[1，] -1 # 导函数计算结果y'=-sin（x）=-sin（pi/2）=-1

7.正切函数

计算y=tan（x）函数的导数，根据导数计算公式，用于手动计算的变形结果为y'=sec^2（x）=1/cos^2（x），当x=π/6时，y'=1.333333。

> dx<-deriv（y~tan（x），"x"，func = TRUE）
> dx（pi/6）
[1] 0.5773503
attr（，"gradient"）
x
[1，] 1.333333 # 导函数计算结果y'=1/cos（x）^2=1/cos（pi/6）^2=1.333333

8.余切函数

计算y=cot（x）函数的导数，由于R语言没有cot（）函数，所以根据三角公式我们手动变形原函数为y=cot（x）=1/tan（x）后再进行导数计算，根据导数计算公式，用于手动计算的变形结果为y'=-csc^2（x）=-1/sin^2（x），当x=π/6时，y'=-4。

> dx<-deriv（y~1/tan（x），"x"，func = TRUE）
> dx（pi/6）
[1] 1.732051
attr（，"gradient"）
x
[1，] -4 # 导函数计算结果y'=-1/sin（x）^2=-1/sin（pi/6）^2=-4

9.反正弦函数

计算y=arcsin（x）函数的导数，根据导数计算公式，用于手动计算的变形结果为，当x=π/6时，y'=1.173757。

> dx<-deriv（y~asin（x），"x"，func = TRUE）
> dx（pi/6）
[1] 0.5510696
attr（，"gradient"）
x
[1，] 1.173757 # 导函数计算结果y'=1/sqrt（1-x^2）=1/sqrt（1-（pi/6）^2）=1.173757

10.反余弦函数

计算y=arccos（x）函数的导数，根据导数计算公式，用于手动计算的变形结果为y'=，当x=π/8时，y'=-1.08735。

> dx<-deriv（y~acos（x），"x"，func = TRUE）
> dx（pi/8）
[1] 1.167232
attr（，"gradient"）
x
[1，] -1.08735 # 导函数计算结果y'=-1/sqrt（1-x^2）=-1/sqrt（1-（pi/8）^2）=-1.08735

11.反正切函数

计算y=arctan（x）函数的导数，根据导数计算公式，用于手动计算的变形结果为y'=1/（1+x^2），当x=π/6时，y'=0.7848335。

> dx<-deriv（y~atan（x），"x"，func = TRUE）
> dx（pi/6）
[1] 0.4823479
attr（，"gradient"）
x
[1，] 0.7848335 # 导函数计算结果y'= 1/（1+x^2） = 1/（1+（pi/6）^2）=0.7848335

1.5.3　二阶导数计算

当我们对一个函数进行多次连续求导计算，就会形成高阶导数。一般地，函数y=f（x）的导数y'=f'（x）仍然是x的函数，我们就把y'=f'（x）的导数叫做函数y=f（x）的二阶导数，记作y''，即

一阶导数的导数叫做二阶导数，二阶导数的导数叫做三阶导数，N-1阶导数的导数叫做N阶导数，习惯上把二阶以上的导数称之为高阶导数。

下面计算函数y=sin（ax）的二阶导数y''，其中a为常数。根据导数计算公式，用手动计算的变形结果，一阶导数为y'=acos（ax），对y'再求导公式变形为，y''=-a^2sin（ax）

用R语言进行程序实现

> a<-2 # 设置a的值
> dx<-deriv（y~sin（a*x），"x"，func = TRUE） # 生成一阶导数公式
> dx（pi/3） # 计算一阶导数
[1] 0.8660254
attr（，"gradient"）
x
[1，] -1 # 导函数计算结果y'= a*cos（a*x）=2*cos（2*pi/3）=-1
> dx<-deriv（y~a*cos（a*x），"x"，func = TRUE） # 对一阶导函数求导
> dx（pi/3）
[1] -1
attr（，"gradient"）
x
[1，] -3.464102 # 导函数计算结果y'= -a^2*sin（a*x）=-2^2*sin（2*pi/3）=-3.464102

上面二阶导数的计算，我们是手动划分为两次求导进行计算的，利用deriv3（）函数其实合并成一步计算。

> dx<-deriv3（y~sin（a*x），"x"，func = TRUE） # 生成二阶导数公式
> dx（pi/3） # 计算导数
[1] 0.8660254
attr（，"gradient"）
x
[1，] -1 # 一阶导数结果
attr（，"hessian"）， ， x
x
[1，] -3.464102 # 二阶导数结果

我们再计算另外一个二阶导数，计算y=ax^4+bx^3+x^2+x+c，其中a，b，c为常数，a=2，b=1，c=3，根据导数计算公式，手动计算的变形结果，一阶导数为y'=（2x^4+x^3+x^2+x+3'）=8x^3+3x^2+2x+1，当x=2时，y'=81，对y'再求导公式变形为，y''=24x^2+6x+2，当x=2时，y''=110。

> dx<-deriv3（y~a*x^4+b*x^3+x^2+x+c，"x"，func=function（x，a=2，b=1，c=3）{}）
# 通过func参数，指定常数值
> dx（2）
[1] 49
attr（，"gradient"）
x
[1，] 81 # 一阶导数结果
attr（，"hessian"）， ， x
x
[1，] 110 # 二阶导数结果

这样就直接完成了二阶导数的计算，在R语言中二阶导数是可以直接求出的，想计算更高阶的导数就需要其他的数学工具包了。

1.5.4　偏导数计算

在一元函数中，我们已经知道导数就是函数的变化率。对于二元函数我们同样要研究它的“变化率”。然而，由于自变量多了一个，情况就要复杂得多。在数学中，一个多变量的函数的偏导数，就是它关于其中一个变量的导数而保持其他变量恒定（相对于全导数，在其中所有变量都允许变化）。偏导数的算子符号为。记作f/x或者f'x。偏导数反映的是函数沿坐标轴正方向的变化率，在向量分析和微分几何中是很有用的。

在xOy平面内，当动点由P（x_0，y_0）沿不同方向变化时，函数f（x，y）的变化快慢一般来说是不同的，因此就需要研究f（x，y）在点（x_0，y_0）处沿不同方向的变化率。在这里我们只学习函数f（x，y）在xOy平面沿着平行于x轴和平行于y轴两个特殊方位变动时，f（x，y）的变化率。

x方向的偏导数：设有二元函数z=f（x，y），点（x_0，y_0）是其定义域D内一点。把y固定在y_0而让x在x_0有增量Δx，相应地函数z=f（x，y）有增量（称为对x的偏增量）Δz=f（x_0+Δx，y_0）-f（x_0，y_0）。如果Δz与Δx之比当Δx→0时的极限存在，那么此极限值称为函数z=f（x，y）在（x_0，y_0）处对x的偏导数（partial derivative）。记作f'x（x_0，y_0）。

y方向的偏导数：函数z=f（x，y）在（x_0，y_0）处对x的偏导数，实际上就是把y固定在y_0（看成常数）后，一元函数z=f（x，y_0）在x_0处的导数。同样，把x固定在x_0，让y有增量Δy，如果极限存在那么此极限称为函数z=（x，y）在（x_0，y_0）处对y的偏导数。记作f'y（x_0，y_0）。

同样，我们可以通过R语言的deriv（）函数进行偏导数的计算。下面我们计算一个二元函数f（x，y）=2x^2+y+3xy^2的偏导数，由于二元函数曲面上每一点都有无穷多条切线，描述这个函数的导数就会相当困难。如果让其中的一个变量y取值为常数，那么就可以求出关于另一个自变量x的偏导数了，即f/x。

下面我们分别对x，y两个自变量求偏导数，设变量y为常数，计算x的偏导数f/x=4x+3y^2，当x=1，y=1时，x的偏导数f/x=4x+3y^2=7。设变量x为常数，计算y的偏导数f/y=1+6xy，当x=1，y=1时，y的偏导数f/x=1+6xy=7。R语言程序实现如下。

> fxy = expression（2*x^2+y+3*x*y^2） # 二元函数公式
> dxy = deriv（fxy， c（"x"， "y"）， func = TRUE）
> dxy
function （x， y）
{
.expr4 <- 3 * x
.expr5 <- y^2
.value <- 2 * x^2 + y + .expr4 * .expr5
.grad <- array（0， c（length（.value）， 2L）， list（NULL， c（"x"，"y"）））
.grad[， "x"] <- 2 * （2 * x） + 3 * .expr5
.grad[， "y"] <- 1 + .expr4 * （2 * y）
attr（.value， "gradient"） <- .grad
.value
}
> dxy（1，1） # 设置自变量
[1] 6
attr（，"gradient"）
x y # 计算结果，x的偏导数为7，y的偏导数为7
[1，] 7 7

偏导数的程序计算结果与手动计算结果是一致的。

下面我们再求一个复杂函数的偏导数，计算一个二元函数f（x，y）=xy+exy+x^2-2xy+y^3+sin（xy）在点（1，3）和点（0，0）的偏导数。R语言程序实现如下。

> fxy = expression（x^y + exp（x * y） + x^2 - 2 * x * y + y^3 + sin（x*y））
> dxy = deriv（fxy， c（"x"， "y"）， func = TRUE）
> dxy（1，3） # 设置自变量
[1] 43.22666
attr（，"gradient"）
x y
[1，] 56.28663 44.09554 # 计算结果，x的偏导数为56.28663，y的偏导数为 44.09554
> dxy（0，0）
[1] 2
attr（，"gradient"）
x y
[1，] NaN -Inf # 计算结果，x的偏导数无意义，y的偏导数负无穷大

对于计算结果有异议的同学，可以尝试手动计算。

本节我们学习了用R语言做高等数学的导数计算，真的是非常方便，这下更有动力学习高数了。

第2章　R语言的算法实现

本章用R语言实现了4个算法案例，包括协同过滤算法、PageRank算法、均线模型算法和遗传算法，希望这些案例可以帮助读者理解R语言在实际业务中的应用。

2.1　用R重写Mahout协同过滤算法

问题

如何用R语言实现推荐算法？

引言

推荐系统在互联网应用中很常见，比如亚马逊为你推荐购书列表，豆瓣为你推荐电影列表。Mahout是Hahoop家族用于机器学习的分步式计算框架，主要包括三类算法，即推荐算法、聚类算法和分类算法。本节将用R语言来重写推荐部分的基于用户的协同过滤算法。用R语言重写Mahout的基于用户的协同过滤推荐算法，将完全按照Mahout的思路和设计进行实现，并与Mahout的计算结果进行对比。

2.1.1　Mahout的推荐算法模型

首先我们需要了解一下，协同过滤算法在Mahout中是如何实现的。Mahout的推荐算法定义了一套标准化的模型构建过程和调用过程，以基于用户的协同过滤算法（UserCF）为例，如图2-1所示。

图2-1　Mahout推荐算法模型（摘自《Mahout In Action》）

从图2-1中我们可以看到，基于用户的协同过滤算法是被模块化的，通过4个模块进行统一的方法调用。首先，创建数据模型（DataModel），然后定义用户的相似度算法（UserSimilarity），接下来定义用户近邻算法（UserNeighborhood），最后调用推荐算法（Recommender）完成计算过程。而基于物品的协同过滤算法（ItemCF）过程也是类似的，去掉第三步计算用户的近邻算法就行了。

本节中将用R语言对Mahout的0.5版本算法进行重新实现，下面是Mahout在Maven中版本定义。

<dependency>
<groupId>org.apache.mahout</groupId>
<artifactId>mahout-core</artifactId>
<version>0.5</version>
</dependency>

我们选用一组比较简单的测试数据集testCF.csv，数据集分为3列：用户ID、物品ID以及用户对物品的打分。一共21行数据。

1，101，5.0
1，102，3.0
1，103，2.5
2，101，2.0
2，102，2.5
2，103，5.0
2，104，2.0
3，101，2.5
3，104，4.0
3，105，4.5
3，107，5.0
4，101，5.0
4，103，3.0
4，104，4.5
4，106，4.0
5，101，4.0
5，102，3.0
5，103，2.0
5，104，4.0
5，105，3.5
5，106，4.0

我们先看一下如何用Java语言使用Mahout库的API，实现基于用户的协同过滤算法的代码。Java程序实现代码如下所示。

/**
* UserCF测试，单机算法实现程序
*/
public class UserCF {
final static int NEIGHBORHOOD_NUM = 2； // 取2个近邻
final static int RECOMMENDER_NUM = 3； // 保留3个推荐结果
public static void main（String[] args） throws IOException， TasteException {
String file = "item.csv"； // 读入数据集
DataModel model = new FileDataModel（new File（file））； // 加载数据到内存对象DataModel
UserSimilarity user = new EuclideanDistanceSimilarity（model）；
// 定义用户相似度距离
NearestNUserNeighborhood neighbor = new NearestNUserNeighborhood
（NEIGHBORHOOD_NUM， user， model）； // 定义近邻
Recommender r = new GenericUserBasedRecommender（model， neighbor， user）；
// 创建推荐模型
LongPrimitiveIterator iter = model.getUserIDs（）； // 取得用户列表
while （iter.hasNext（）） { // 循环用户列表，计算给每个用户的推荐结果
long uid = iter.nextLong（）；
List list = r.recommend（uid， RECOMMENDER_NUM）；
System.out.printf（"uid：%s"， uid）；
for （RecommendedItem ritem ： list） {
System.out.printf（"（%s，%f）"， ritem.getItemID（）， ritem.getValue（））；
// 打印推荐结果
}
System.out.println（）；
}
}
}

运行Java程序，输出推荐结果。

uid：1（104，4.250000）（106，4.000000）
uid：2（105，3.956999）
uid：3（103，3.185407）（102，2.802432）
uid：4（102，3.000000）
uid：5

对结果的解读如下。

·给uid=1的用户，推荐计算得分最高的2个物品，104和106。

·给uid=2的用户，推荐计算得分最高的1个物品，105。

·给uid=3的用户，推荐计算得分最高的2个物品，103和102。

·给uid=4的用户，推荐计算得分最高的1个物品，102。

·给uid=5的用户，没有推荐。

2.1.2　R语言模型实现

接下来，我们使用R语言重写Mahout的实现，R语言代码将完全按照Mahout源代码的程序设计思路进行实现。为保证与Java程序思路一致，R代码用了for循环实现，这里暂时不考虑R程序的性能。

用R语言构建算法模型，将按照下面的5个步骤进行：

（1）建立数据模型

（2）欧氏距离相似度算法

（3）用户近邻算法

（4）推荐算法

（5）运行程序

1.建立数据模型

创建数据模型的函数FileDataModel（），主要用于从CSV文件中读取数据，然后以R语言中矩阵类型（matrix）加载到内存中。

FileDataModel<-function（file）{ # 数据模型函数
data<-read.csv（file，header=FALSE） # 读CSV文件到内存
names（data）<-c（"uid"，"iid"，"pref"） # 增加列名
user <- unique（data$uid） # 计算用户数
item <- unique（sort（data$iid）） # 计算产品数
uidx <- match（data$uid， user）
iidx <- match（data$iid， item）
M <- matrix（0， length（user）， length（item）） # 定义存储矩阵
i <- cbind（uidx， iidx， pref=data$pref）
for（n in 1：nrow（i））{ # 给矩阵赋值
M[i[n，][1]，i[n，][2]]<-i[n，][3]
}
dimnames（M）[[2]]<-item
M # 返回矩阵数据
}

2.欧氏距离相似度算法

我们在计算用户相似度算法的时候可以有多种选择，如欧氏距离相似度算法、皮尔森相似度算法、余弦相似度算法、Spearman秩相关系数相似度算法、曼哈顿距离相似度算法、对数似然相似度算法等，很多算法都有对应的R语言函数，直接调用就可以了。按照Mahout的代码实现思路，它对于基础的算法做了一些优化，因此我们也需要完全从底层重写这些算法。

下面将以欧氏距离相似度算法为例，创建欧氏距离相似度的计算函数Euclidean-DistanceSimilarity（），加载用户物品的矩阵数据，通过欧氏距离来计算用户的相似度。

EuclideanDistanceSimilarity<-function（M）{
row<-nrow（M）
s<-matrix（0， row， row） # 相似度矩阵
for（z1 in 1：row）{
for（z2 in 1：row）{
if（z1<z2）{
num<-intersect（which（M[z1，]！=0），which（M[z2，]！=0）） # 可计算的列
sum<-0
for（z3 in num）{
sum<-sum+（M[z1，][z3]-M[z2，][z3]）^2
}
s[z2，z1]<-length（num）/（1+sqrt（sum））
if（s[z2，z1]>1） s[z2，z1]<-1 # 对算法的阈值进行限制
if（s[z2，z1]<-1） s[z2，z1]<- -1
}
}
}
ts<-t（s） # 补全三角矩阵
w<-which（upper.tri（ts））
s[w]<-ts[w]
s # 返回用户相似度矩阵
}

3.用户近邻算法

我们在计算用户近邻的时候，也有2种算法来选择。一种是以个数来计算的，选出最近的前几个；另一种是以百分比来计算的，选出最近的前百分之几的数量。下面将以个数计算为例，选出最近的前N个用户。创建最近邻计算的函数NearestNUserNeighborhood（），传入用户的相似度矩阵和个数，就能计算出用户最近邻了。

NearestNUserNeighborhood<-function（S，n）{
row<-nrow（S）
neighbor<-matrix（0， row， n）
for（z1 in 1：row）{
for（z2 in 1：n）{
m<-which.max（S[，z1]）
neighbor[z1，][z2]<-m
S[，z1][m]=0
}
}
neighbor # 返回前n个最近邻
}

4.推荐算法

我们在计算推荐的时候，也有几种算法可以选择，如基于用户的推荐算法、基于物品的推荐算法、slopeOne推荐算法、itemKNN推荐算法、SVD推荐算法、TreeCluster推荐算法，这几种推荐算法要与上面定义的数据和相似度算法进行匹配才能一起使用。

下面我们创建基于用户的推荐算法计算的函数UserBasedRecommender（），通过用户物品数据矩阵、用户相似度矩阵、用户最近邻，按基于用户的协同过滤算法实现，计算出推荐结果。

UserBasedRecommender<-function（uid，n，M，S，N）{
row<-ncol（N）
col<-ncol（M）
r<-matrix（0， row， col）
N1<-N[uid，]
for（z1 in 1：length（N1））{
num<-intersect（which（M[uid，]==0），which（M[N1[z1]，]！=0）） # 可计算的列
for（z2 in num）{
r[z1，z2]=M[N1[z1]，z2]*S[uid，N1[z1]]
}
}
# print（r） # 打印每个用户的推荐矩阵
sum<-colSums（r）
s2<-matrix（0， 2， col）
for（z1 in 1：length（N1））{
num<-intersect（which（colSums（r）！=0），which（M[N1[z1]，]！=0））
for（z2 in num）{
s2[1，][z2]<-s2[1，][z2]+S[uid，N1[z1]]
s2[2，][z2]<-s2[2，][z2]+1
}
}
s2[，which（s2[2，]==1）]=10000
s2<-s2[-2，]
r2<-matrix（0， n， 2）
rr<-sum/s2
item <-dimnames（M）[[2]]
for（z1 in 1：n）{
w<-which.max（rr）
if（rr[w]>0.5）{
r2[z1，1]<-item[which.max（rr）]
r2[z1，2]<-as.double（rr[w]）
rr[w]=0
}
}
r2
}

这样基于用户的协同过滤算法的函数，我们都已经用R程序实现了。下面按照调用关系，我们运行这些功能函数。

5.运行程序

> FILE<-"item.csv" # 数据文件
> NEIGHBORHOOD_NUM<-2 # 取2个最大近邻
> RECOMMENDER_NUM<-3 # 保留最多3个推荐结果
> M<-FileDataModel（FILE） # 把数据文件，换成矩阵加载到内存
> S<-EuclideanDistanceSimilarity（M） # 计算用户相似度矩阵
> N<-NearestNUserNeighborhood（S，NEIGHBORHOOD_NUM） # 计算用户近邻
> R1<-UserBasedRecommender（1，RECOMMENDER_NUM，M，S，N）；R1 # 查看对User=1的推荐结果
[，1] [，2]
[1，] "104" "4.25"
[2，] "106" "4"
[3，] "0" "0"
> R2<-UserBasedRecommender（2，RECOMMENDER_NUM，M，S，N）；R2 # 查看对User=2的推荐结果
[，1] [，2]
[1，] "105" "3.95699903407931"
[2，] "0" "0"
[3，] "0" "0"
> R3<-UserBasedRecommender（3，RECOMMENDER_NUM，M，S，N）；R3 # 查看对User=3的推荐结果
[，1] [，2]
[1，] "103" "3.18540697329411"
[2，] "102" "2.80243217111765"
[3，] "0" "0"
> R4<-UserBasedRecommender（4，RECOMMENDER_NUM，M，S，N）；R4 # 查看对User=4的推荐结果
[，1] [，2]
[1，] "102" "3"
[2，] "0" "0"
[3，] "0" "0"
> R5<-UserBasedRecommender（5，RECOMMENDER_NUM，M，S，N）；R5 # 查看对User=5的推荐结果
[，1] [，2]
[1，] 0 0
[2，] 0 0
[3，] 0 0

最后我们看到计算结果，同调用Mahout的API的Java程序的计算结果是一致的。

2.1.3　算法实现的原理——矩阵变换

那么我们算法实现的原理是什么呢？所谓协同过滤算法，其实就是矩阵变换的结果！请大家下面留意每一步的矩阵变换。从原始数据文件开始，如下所示。

1，101，5.0
1，102，3.0
1，103，2.5
2，101，2.0
2，102，2.5
2，103，5.0
2，104，2.0
3，101，2.5
3，104，4.0
3，105，4.5
3，107，5.0
4，101，5.0
4，103，3.0
4，104，4.5
4，106，4.0
5，101，4.0
5，102，3.0
5，103，2.0
5，104，4.0
5，105，3.5
5，106，4.0

第一步的矩阵变换，通过FileDataModel（）函数，输出用户物品矩阵。

101 102 103 104 105 106 107
[1，] 5.0 3.0 2.5 0.0 0.0 0 0
[2，] 2.0 2.5 5.0 2.0 0.0 0 0
[3，] 2.5 0.0 0.0 4.0 4.5 0 5
[4，] 5.0 0.0 3.0 4.5 0.0 4 0
[5，] 4.0 3.0 2.0 4.0 3.5 4 0

第二步，利用欧氏相似度算法进行矩阵变换，运行EuclideanDistanceSimilarity（）函数，结果如下所示。

[，1] [，2] [，3] [，4] [，5]
[1，] 0.0000000 0.6076560 0.2857143 1.0000000 1.0000000
[2，] 0.6076560 0.0000000 0.6532633 0.5568464 0.7761999
[3，] 0.2857143 0.6532633 0.0000000 0.5634581 1.0000000
[4，] 1.0000000 0.5568464 0.5634581 0.0000000 1.0000000
[5，] 1.0000000 0.7761999 1.0000000 1.0000000 0.0000000

第三步，通过用户相似度矩阵，计算出用户最近邻，运行EuclideanDistanceSimilarity（）函数，结果如下所示。

top1 top2
[1，] 4 5
[2，] 5 3
[3，] 5 2
[4，] 1 5
[5，] 1 3

第四步，把上面的矩阵合并计算，通过基于用户的推荐算法，得到每个用户的推荐矩阵。以uid=1的用户为例，运行UserBasedRecommender（）函数，结果如下所示。

101 102 103 104 105 106 107
4 0 0 0 4.5 0.0 4 0
5 0 0 0 4.0 3.5 4 0

打开注释行：UserBasedRecommender（）函数的代码注释print（r）#打印每个用户的推荐矩阵。

第五步，过滤推荐矩阵的结果，取前2个得分最高的推荐结果返回。以uid=1的用户为例，结果如下所示。

推荐物品 物品得分
[1，] "104" "4.25"
[2，] "106" "4"

通过这5步矩阵变换，我们就可以清楚地看到基于用户的协同过滤算法的本质了。当然，Mahout所提供的算法。都是以矩阵为基础的可以处理海量数据的算法。如果我们的数据量很小，可以把上面的算法过程优化并改进，降低矩阵计算的复杂度。

2.1.4　算法总结

本节只是用R语言重写了Mahout的基于用户的、欧氏距离相似度、个数最近邻的协同过滤算法，重写其他的算法过程也是类似的。另外，在读Mahout源代码的过程中发现，Mahout做各种算法时，都有自己的优化，并不是简单地套用教课书上的算法公式。比如，计算基于欧氏距离的用户相似度时，并不是标准的欧氏距离算法，而是改进的欧氏距离算法。

similar = 1/（1+sqrt（ （a-b）^2 + （a-c）^2 ）） # 欧氏距离算法
similar = n/（1+sqrt（ （a-b）^2 + （a-c）^2 ）） # 改进的欧氏距离算法

公式解释：

·a，b是被两个用户都打分的物品，也可能是1个或者多个

·n是被两个用户都打分的物品的个数

·当similar>1时，则similar=1

·当similar<-1时，则similar=-1

通过算法的优化，Mahout可以给出更准确的推荐结果。所以，想用Mahout做推荐引擎的同学，就要对自己要求高一点，不仅要会Java，会Mahout，还要知道底层算法以及Mahout对算法的改动，这样Mahout在你手中才能发挥出真正的威力！关于Mahout的更多文章，请查阅笔者的博客（http://blog.fens.me/hadoop-mahout-roadmap/）。

2.2　PageRank算法R语言实现

问题

如何用R语言实现PageRank算法？

引言

Google搜索，早已成为我每天必用的工具，我无数次惊叹它搜索结果的准确性。同时，我也在做Google的SEO，推广自己的博客。经过几个月尝试，我的博客PR到2了，外链也有几万个。总结下来，还是感叹PageRank的神奇。笔者认为PageRank是改变互联网的算法！

2.2.1　PageRank算法介绍

PageRank是Google专有的算法，用于衡量特定网页相对于搜索引擎索引中的其他网页而言的重要程度。它由Larry Page和Sergey Brin在20世纪90年代后期发明。PageRank实现了将链接价值概念作为排名因素。

PageRank是让链接来“投票”。一个页面的“得票数”由所有链向它的页面的重要性来决定，指向一个页面的超链接相当于对该页投一票。一个页面的PageRank是由所有链向它的页面（链入页面）的重要性经过递归算法得到的。一个有较多链入的页面会有较高的等级，相反如果一个页面没有任何链入页面，那么它没有等级。简单一句话概括，就是从许多优质的网页链接过来的网页，必定还是优质网页。

PageRank的计算基于以下两个基本假设，一是数量假设，即如果一个页面节点接收到的其他网页指向的入链数量越多，那么这个页面越重要；二是质量假设，即指向页面A的入链质量不同，质量高的页面会通过链接向其他页面传递更多的权重，所以越是质量高的页面指向页面A，页面A越重要。

要提高PageRank有3个要点，也就是我们做SEO时必须要考虑的问题：

（1）反向链接数：反向链接数越多，指向页面的权重越高。

（2）反向链接是否来自PageRank较高的页面：反向链接页面的权重越高，指向页面分配的权重就越高。

（3）反向链接源页面的链接数：反向链接页面的链接数越多，则反向链接源页面的权重越高。循环解释前面两条。

2.2.2　PageRank算法原理

在初始阶段，网页通过链接关系构建起有向图，每个页面设置相同的PageRank值，通过若干轮的递归计算，会得到每个页面所获得的最终PageRank值。随着每一轮的计算进行，网页当前的PageRank值会不断得到更新。

在一轮更新页面PageRank得分的计算中，每个页面将其当前的PageRank值平均分配到本页面所包含的出链上，这样每个链接即获得了相应的权值。而每个页面将所有指向本页面的入链所传入的权值求和，即可得到新的PageRank得分。当每个页面都获得了更新后的PageRank值，就完成了一轮PageRank计算。

1.算法原理

PageRank算法建立在随机冲浪者模型上，其基本思想是：网页的重要性排序是由网页间的链接关系所决定的，算法是依靠网页间的链接结构来评价每个页面的等级和重要性，一个网页的PR值涉及指向它的链接网页数，还涉及指向它的网页的其他网页本身的重要性。

PageRank具有两大特性，一是PR值的传递性，即网页A指向网页B时，网页A的PR值会部分传递给网页B；二是重要性的传递性，即一个重要的网页比一个不重要网页，传递的权重要更多。

2.计算公式

PageRank算法公式为（2.1）：

其中PR（pi）是pi页面的PageRank值，n是所有页面的数量，pi是不同的网页p_1、p_2、p_3，M（i）是pi链入网页的集合，L（j）是pj链出网页的数量，d是阻尼系数，任意时刻，用户到达某页面后并继续向后浏览的概率。通过经验值，Google设置d=0.85，则1-d=0.15表示用户停止点击随机跳到新URL的概率，d的取值范围是0<d≤1。

3.构造实例：以4个页面的数据为例

我们以4个页面的数据为例，构造一个简单的PageRank实例模型，如图2-2所示。

图2-2　PageRank构造实例

在图2-2中，ID=1的页面链向页面2、3、4，所以一个用户从ID=1的页面跳转到2、3、4的概率各为1/3，ID=2的页面链向页面3和4，所以一个用户从ID=2的页面跳转到3，4的概率各为1/2，ID=3的页面链向页面4，所以一个用户从ID=3的页面跳转到4的概率各为1，ID=4的页面链向页面2，所以一个用户从ID=4的页面跳转到2的概率各为1。

下面我们开始构建PageRank的数据模型和转移矩阵。第一步，通过网页的链接关系，构造出邻接表：

链接源页面 链接目标页面
1 2，3，4
2 3，4
3 4
4 2

第二步，通过邻接表，构建邻接矩阵（方阵），其中列表示源页面，行表示目标页面。

[，1] [，2] [，3] [，4]
[1，] 0 0 0 0
[2，] 1 0 0 1
[3，] 1 1 0 0
[4，] 1 1 1 0

第三步，把邻接矩阵，转换为概率矩阵（转移矩阵）。

[，1] [，2] [，3] [，4]
[1，] 0 0 0 0
[2，] 1/3 0 0 1
[3，] 1/3 1/2 0 0
[4，] 1/3 1/2 1 0

这样，通过网页的链接关系，我们就构造出了概率转移矩阵。

2.2.3　R语言单机算法实现

下面我们用R语言实现从邻接表到转移矩阵的构建过程，创建数据文件page.csv，用于表示网页的邻接表。

1，2
1，3
1，4
2，3
2，4
3，4
4，2

分别用下面3种方式实现PageRank模型，即未考虑阻尼系统的情况，考虑阻尼系统的情况，直接用R的矩阵特征值函数计算。

1.未考虑阻尼系统的情况

R语言实现如下：

> adjacencyMatrix<-function（pages）{ # 构建邻接矩阵
+ n<-max（apply（pages，2，max））
+ A <- matrix（0，n，n）
+ for（i in 1：nrow（pages）） A[pages[i，]$dist，pages[i，]$src]<-1
+ A
+}
> probabilityMatrix<-function（G）{ # 变换概率矩阵
+ cs <- colSums（G）
+ cs[cs==0] <- 1
+ n <- nrow（G）
+ A <- matrix（0，nrow（G），ncol（G））
+ for （i in 1：n） A[i，] <- A[i，] + G[i，]/cs
+ A
+}
> eigenMatrix<-function（G，iter=100）{ # 递归计算矩阵特征值
+ iter<-10
+ n<-nrow（G）
+ x <- rep（1，n）
+ for （i in 1：iter） x <- G %*% x
+ x/sum（x）
+}
# 运行程序
> pages<-read.table（file="page.csv"，header=FALSE，sep="，"） # 读数据文件到内存
> names（pages）<-c（"src"，"dist"）；pages # 设置数据的header
src dist
1 1 2
2 1 3
3 1 4
4 2 3
5 2 4
6 3 4
7 4 2
> A<-adjacencyMatrix（pages）；A # 构建邻接矩阵
[，1] [，2] [，3] [，4]
[1，] 0 0 0 0
[2，] 1 0 0 1
[3，] 1 1 0 0
[4，] 1 1 1 0
> G<-probabilityMatrix（A）；G # 概率转移矩阵
[，1] [，2] [，3] [，4]
[1，] 0.0000000 0.0 0 0
[2，] 0.3333333 0.0 0 1
[3，] 0.3333333 0.5 0 0
[4，] 0.3333333 0.5 1 0
> q<-eigenMatrix（G，100）；q # PageRank值
[，1]
[1，] 0.0000000
[2，] 0.4036458
[3，] 0.1979167
[4，] 0.3984375

结果解读如下：

·ID=1的页面，PR值是0，因为没有指向ID=1的页面。

·ID=2的页面，PR值是0.4，权重最高，因为页面1和4都指向页面2，页面4权重较高，并且页面4只有一个链接指向页面2，权重传递没有损失。

·ID=3的页面，PR值是0.19，虽有页面1和2都指向了页面3，但是页面1和2还指向其他页面，权重被分散了，所以ID=3的页面PR并不高。

·ID=4的页面，PR值是0.39，权重很高，因为被页面1，2，3都指向了。

从上面的结果，我们发现ID=1的页面，PR值是0，那么ID=1的页面，就不能向其他页面输出权重了，计算就会不合理！所以，增加阻尼系数d，修正没有链接指向的页面，保证页面的最小PR值>0。

2.考虑阻尼系统的情况

这里增加函数dProbabilityMatrix。

> dProbabilityMatrix<-function（G，d=0.85）{ # 变换概率矩阵，考虑阻尼系数d的情况
+ cs <- colSums（G）
+ cs[cs==0] <- 1
+ n <- nrow（G）
+ delta <- （1-d）/n
+ A <- matrix（delta，nrow（G），ncol（G））
+ for （i in 1：n） A[i，] <- A[i，] + d*G[i，]/cs
+ A
+}
# 运行程序
> pages<-read.table（file="page.csv"，header=FALSE，sep="，"） # 读数据文件到内存
> names（pages）<-c（"src"，"dist"） # 设置数据的header
> A<-adjacencyMatrix（pages）；A # 构建邻接矩阵
[，1] [，2] [，3] [，4]
[1，] 0 0 0 0
[2，] 1 0 0 1
[3，] 1 1 0 0
[4，] 1 1 1 0
> G<-dProbabilityMatrix（A）；G # 概率转移矩阵，考虑阻尼系数d的情况
[，1] [，2] [，3] [，4]
[1，] 0.0375000 0.0375 0.0375 0.0375
[2，] 0.3208333 0.0375 0.0375 0.8875
[3，] 0.3208333 0.4625 0.0375 0.0375
[4，] 0.3208333 0.4625 0.8875 0.0375
> q<-eigenMatrix（G，100）；q # PageRank值
[，1]
[1，] 0.0375000
[2，] 0.3738930
[3，] 0.2063759
[4，] 0.3822311

增加阻尼系数后，ID=1的页面，就有值了PR（1）=（1-d）/n=（1-0.85）/4=0.0375，即无外链页面的最小值。

3.直接用R的特征值计算函数

上面的算法，我们做的都是递归计算，通过多次循环得到矩阵的特征值。R语言本身提供了直接计算特征值的函数，我们可以直接调用，从而简化代码的复杂度。下面增加计算特征值函数calcEigenMatrix。

> calcEigenMatrix<-function（G）{ # 直接计算矩阵特征值
+ x <- Re（eigen（G）$vectors[，1]）
+ x/sum（x）
+ }
# 运行程序
> pages<-read.table（file="page.csv"，header=FALSE，sep="，"） # 读数据文件到内存
> names（pages）<-c（"src"，"dist"） # 设置数据的header
> A<-adjacencyMatrix（pages）；A # 构建邻接矩阵
[，1] [，2] [，3] [，4]
[1，] 0 0 0 0
[2，] 1 0 0 1
[3，] 1 1 0 0
[4，] 1 1 1 0
> G<-dProbabilityMatrix（A）；G # 通过特征值函数计算，概率转移矩阵
[，1] [，2] [，3] [，4]
[1，] 0.0375000 0.0375 0.0375 0.0375
[2，] 0.3208333 0.0375 0.0375 0.8875
[3，] 0.3208333 0.4625 0.0375 0.0375
[4，] 0.3208333 0.4625 0.8875 0.0375
> q<-calcEigenMatrix（G）；q # PageRank值
[1] 0.0375000 0.3732476 0.2067552 0.3824972

直接计算矩阵特征值，可以有效地减少循环的操作，提高程序运行效率。

2.2.4　R语言分步式算法实现

使用PageRank的场景大都是基于海量数据的，通常会用Hadoop的解决方案，通过分步式并行算法计算出每个页面的得分。利用R语言，我可以先构建出分步式算法的原型，保证分步式算法的结果与单机算法的结果是一致的，从而总结出分步式算法的计算公式，再用Hadoop的MapReduce进行重写，从而达到生产环境的上线要求。

1.PageRank算法分步式原理

PageRank的分步式算法原理，简单来讲，就是通过矩阵计算实现并行化。我们直接从邻接矩阵开始说起，对于Hadoop来说需要把邻接矩阵的列按数据行存储，而R语言可以直接用矩阵对象表示。

[，1] [，2] [，3] [，4]
[1，] 0.0375000 0.0375 0.0375 0.0375
[2，] 0.3208333 0.0375 0.0375 0.8875
[3，] 0.3208333 0.4625 0.0375 0.0375
[4，] 0.3208333 0.4625 0.8875 0.0375

接下来，迭代求矩阵特征值，按照MapReduce的设计思路，把R语言的算法也分为map过程和reduce过程。map过程主要用于数据分组，reduce过程主要用于数据计算，让map和reduce循环迭代，从而计算出矩阵特征值。Hadoop的MapReduce计算过程如图2-3所示。

图2-3　PageRank的MapReduce计算过程

对于Hadoop的map过程，输入为邻接矩阵和pr值；输出中key为pr的行号，value为邻接矩阵和pr值的乘法求和公式。对于Hadoop的reduce过程，输入中key为pr的行号，value为邻接矩阵和pr值的乘法求和公式；输出中key为pr的行号，value为计算的结果，即pr值。

2.R语言程序模拟

我们通过R语言来实现这个程序，把矩阵计算分解为map和reduce两个过程。在map过程中，把数据按一定规则切分成多块，海量数据分布在Hadoop的多个存储节点上用于模拟。本节使用的数据集仅包括了4个网页，我把数据切分成2组，模拟存储在2个Hadoop节点上。

> map <- function（S0， node = "a"） { # map过程函数
+ S <- apply（S0， 2， function（x） x/sum（x））
+ if （node == "a"）
+ S[， 1：2] else S[， 3：4]
+ }

在reduce过程中，数据从多个map节点汇总到reduce节点，进行数据合并计算。通过R语言，我直接在reduce（）函数内部完成了迭代计算的过程。而对完全的分步式的MapReduce来说，每次迭代都要包括完成的map过程和reduce过程。

> reduce <- function（A， B， a = 0.85， niter = 100） { # reduce过程函数
+ n <- nrow（A）
+ q <- rep（1， n）
+ Ga <- a * A + （1 - a）/n * （A[A ！= 1] = 1）
+ Gb <- a * B + （1 - a）/n * （B[B ！= 1] = 1）
+ for （i in 1：niter） { # 迭代计算
+ qa <- as.matrix（q[1：ncol（A）]）
+ qb <- as.matrix（q[（ncol（A） + 1）：n]）
+ q <- Ga %*% qa + Gb %*% qb
+ }
+ as.vector（q/sum（q）） # 标准化PR值
+ }

运行程序，进行100次迭代，计算矩阵特征值（PR值），比较计算结果，发现这与单机的计算结果是一致的。

> S0 <- t（matrix（c（0， 0， 0， 0， 1， 0， 0， 1， 1， 1， 0， 0， 1， 1， 1， 0），nrow = 4））
# 初始数据矩阵
> A <- map（S0， "a"） # 矩阵数据分组
> B <- map（S0， "b"）
> reduce（A， B） # 矩阵数据计算
[1] 0.0375000 0.3732476 0.2067552 0.3824972

3.矩阵的计算过程

对于每次迭代计算的PR值，我们可以打印出来，从而清楚地看到每次迭代的结果。把reduce（）函数的代码稍加修改，增加原始PR值输出和标准化的PR值输出。

> reduce <- function（A， B， a = 0.85， niter = 100） {
+ n <- nrow（A）
+ q <- rep（1， n）
+ Ga <- a * A + （1 - a）/n * （A[A ！= 1] = 1）
+ Gb <- a * B + （1 - a）/n * （B[B ！= 1] = 1）
+ for （i in 1：niter） {
+ qa <- as.matrix（q[1：ncol（A）]）
+ qb <- as.matrix（q[（ncol（A） + 1）：n]）
+ q <- Ga %*% qa + Gb %*% qb
+ }
+ print（q） # 原始PR值
+ print（as.vector（q/sum（q））） # 标准化的PR值
+ }

第1次迭代的计算结果。

> reduce（A， B， niter=1） # 原始PR值
[，1]
[1，] 0.1500000
[2，] 1.2833333
[3，] 0.8583333
[4，] 1.7083333
[1] 0.0375000 0.3208333 0.2145833 0.4270833 # 标准化的PR值

第1次迭代时，原始PR值的矩阵计算公式。

0.0375000 0.0375 0.0375 0.0375 1 0.150000
0.3208333 0.0375 0.0375 0.8875 * 1 = 1.283333
0.3208333 0.4625 0.0375 0.0375 1 0.858333
0.3208333 0.4625 0.8875 0.0375 1 1.708333

第2次迭代的计算结果。

> reduce（A， B， niter=2）
[，1]
[1，] 0.1500000
[2，] 1.6445833
[3，] 0.7379167
[4，] 1.4675000
[1] 0.0375000 0.4111458 0.1844792 0.3668750

第2次迭代时，原始PR值的矩阵计算公式。

0.0375000 0.0375 0.0375 0.0375 0.150000 0.150000
0.3208333 0.0375 0.0375 0.8875 * 1.283333 = 1.6445833
0.3208333 0.4625 0.0375 0.0375 0.858333 0.7379167
0.3208333 0.4625 0.8875 0.0375 1.708333 1.4675000

第10次迭代计算结果。

> reduce（A， B， niter=10）
[，1]
[1，] 0.1500000
[2，] 1.4955721
[3，] 0.8255034
[4，] 1.5289245
[1] 0.0375000 0.3738930 0.2063759 0.3822311

第10次迭代时，标准化PR值的矩阵计算公式。

0.150000 0.0375000
1.4955721 / （0.15+1.4955721+0.8255034+1.5289245） = 0.3738930
0.8255034 0.2063759
1.5289245 0.3822311

在了解PageRank的原理后，使用R语言构建PageRank模型，是非常容易的。实际应用中，我们也愿意用比较简单的方式建模、验证后，再用其他更底层的语言实现企业应用！

在我的博客中还有一些进阶的内容，介绍了如何用MapReduce分步式算法来实现PageRank模型，请参考文章《PageRank算法并行实现》（http://blog.fens.me/algorithm-pagerank-mapreduce/）。

2.3　二条均线打天下

问题

如何用R语言编写金融算法模型？

引言

移动平均线（MA）是股市中最常用的一种技术分析方法，用来在大行情的波动段找到有效的交易信号。移动平均线不仅简单，而且有效，对股市操作具有神奇的指导作用。据金融从业人员说，均线模型有效地打败了大部分的主观策略，是炒股、炒期货的必备基本工具。那么本节将深入研究一下均线模型如何在股市中发挥作用。

2.3.1　移动平均线

移动平均（moving average，MA）线是以道·琼斯的“平均成本概念”为理论基础，采用统计学中“移动平均”的原理，将一段时期内的股票价格平均值连成曲线，用来显示股价的历史波动情况，进而反映股价指数未来发展趋势的技术分析方法。它是道氏理论的形象化表述。在技术分析领域中，移动平均线是必不可少的指标工具。移动平均线的计算方法就是求连续若干天的收盘价的算术平均，天数就是MA的参数。

计算公式是MA=（C_1+C_2+C_3+C_4+C_5+…+Cn）/n，其中C为收盘价，n为移动平均周期数。例如，5日移动平均价格计算方法为：

MA_5=（前四天收盘价+前三天收盘价+前天收盘价+昨天收盘价+今天收盘价）/5

移动平均线依时间长短可分为三种，即短期移动平均线、中期移动平均线、长期移动平均线。短期移动平均线一般以5日或10日为计算期间，中期移动平均线大多以30日、60日为计算期间，长期移动平均线大多以100日和200日为计算期间。

移动平均线根据对数据的处理方法，又可分为3种。

（1）简单移动平均线（simple moving average，SMA）：又称“算术移动平均线”，是指对特定期间的收盘价进行简单平均化的意思。一般所提到的移动平均线即指简单移动平均线，本节中介绍的算法模型，也是用的简单移动平均线。

（2）加权移动平均线（weighted moving average，WMA）：是一种按时间进行加权运算的移动平均线。时间越近，价格的权重越大。计算方式是基于加权移动平均线日数，将每一个之前日期比重提升。每个价格会乘以一个权重，最新的价格会有最大的比重，其之前的每一日的比重将会递减。加权移动平均线是移动平均线的改良。

（3）指数平滑移动平均线（exponential moving average，EMA）：是以指数式递减加权的移动平均。各数值的加权影响力随时间而指数式递减，越近期的数据加权影响力越重，但较旧的数据也给予一定的加权值。

2.3.2　均线模型

在交易软件日K线图中，除了标准的价格K线以外，通常还有4条线，分别是白线、黄线、紫线、绿线，依次分别表示5日、10日、20日和60日移动平均线。通过这4条线与价格K线的交叉，就可以形成不同的均线模型。以乐视网（300104）股票日K线图为例，截取2012年8月到2014年7月的股价数据，如图2-4所示。

从图2-4中，我们看到乐视网股价最低价是13.91元，出现在2012年12月；最高价55.50元，出现在2014年1月。这段时期，乐视网的股价一路震荡向上，波动最小的绿色线为60日均线平滑的股价，趋势性比较明显。

图2-4　乐视网股票日K线图

利用均线平滑的特点，可以发现均线与价格K线会有交叉，各均线之间也有交叉，我们可以通过这些交叉点判断交易信号。

·黄金交叉，当10日均线由下往上穿越20日均线，10日均线在上，20日均线在下，其交叉点就是黄金交叉，黄金交叉是多头的表现，出现黄金交叉后，后市会有一定的涨幅空间，这是进场的最佳时机。

·死亡交叉，当20日均线与10日平均线交叉时，20日均线由下住上穿越10日均线，形成20日平均线在上，10日均线在下时，其交点称为“死亡交叉”，“死亡交叉”预示空头市场来临，股市将下跌，此时是出场的最佳时机。

如果很好地运用移动平均线理论，再掌握行情的真正趋势，就能获取可观利润。但移动平均线理论也有局限性，具体如下：

·移动平均线是股价定型后产生的图形，反映较慢，只适用于日间交易；

·移动平均线不能反映股价在当日的变化及成交量的大小，不适用于日内交易；

·移动平均线是趋势性模型，如果股价未形成趋势，只是频繁波动，模型不适用。

2.3.3　用R语言实现均线模型

接下来，我们利用R语言对股票数据进行操作，实现一个均线模型的实例。

1.从互联网下载数据

R语言本身提供了丰富的金融函数工具包，quantmod包就是最常用的一个，不过quantmod包还要配合时间序列包zoo、可扩展的时间序列包xts、指标计算包TTR和可视包ggplot2等一起使用，关于zoo包和xts包的详细使用可以参考《R的极客理想——工具篇》的2.1节和2.2节。

我们首先利用quantmod包，从互联网下载股票数据，并以CSV格式保存到本地。

# 加载工具包
> library（plyr）
> library（quantmod）
> library（TTR）
> library（ggplot2）
> library（scales）
> download<-function（stock，from="2010-01-01"）{ # 下载数据并保存到本地
+ df<-getSymbols（stock，from=from，env=environment（），auto.assign=FALSE） # 下载数据
+ names（df）<-c（"Open"，"High"，"Low"，"Close"，"Volume"，"Adjusted"）
+ write.zoo（df，file=paste（stock，".csv"，sep=""），sep="，"，quote=FALSE） # 保存到本地文件
+}
> read<-function（stock）{ # 从本地文件读数据
+ as.xts（read.zoo（file=paste（stock，".csv"，sep=""），header = TRUE，sep="，"，
format="%Y-%m-%d"））
+}
> stock<-"IBM" # 下载IBM的股票行情数据
> download（stock，from='2010-01-01'）
> IBM<-read（stock） # 把数据加载到内存
> class（IBM） # 查看数据类型
[1] "xts" "zoo"
> head（IBM） # 查看前6条数据
Open High Low Close Volume Adjusted
2010-01-04 131.18 132.97 130.85 132.45 6155300 121.91
2010-01-05 131.68 131.85 130.10 130.85 6841400 120.44
2010-01-06 130.68 131.49 129.81 130.00 5605300 119.66
2010-01-07 129.87 130.25 128.91 129.55 5840600 119.24
2010-01-08 129.07 130.92 129.05 130.85 4197200 120.44
2010-01-11 131.06 131.06 128.67 129.48 5730400 119.18

利用quantmod包的getSymbols（）函数，默认会通过Yahoo金融的开放API下载数据，我们选择IBM的股票行情数据，从2010-01-01到2014-07-09的4年多的日间交易数据。数据类型为xts格式的时间序列，数据包括7个列，以日期做索引列，其他6列分别为开盘价（Open）、最高价（High）、最低价（Low）、收盘价（Close）、交易量（Volume）、调整价（Adjusted）。

2.实现简单的蜡烛图

直接使用quantmod包的chartSeries（）函数，我们可以画出可视化效果还不错的蜡烛图。简单的蜡烛图，如图2-5所示。

> chartSeries（IBM） # 画IBM股票的蜡烛图

如果你想在蜡烛图上增加一些技术指标也是非常方便的，直接把指标函数以参数传给chartSeries（）函数就行了，画出带SMA、MACD、ROC等指标的蜡烛图，所图2-6所示。

> chartSeries（IBM，TA = "addVo（）； addSMA（）； addEnvelope（）；addMACD（）； addROC（）"）
# 画带指标的蜡烛图

图2-5　蜡烛图

图2-6　带指标的蜡烛图

非常简单的2个函数，就可以实现股票数据的可视化。当然，这个功能是封装好的通用的函数，如果我们要自定义策略模型，就需要自己写代码来实现了，比如自定义的支持量机（SVM）分类器模型，不过本节不讲太复杂的模型，而是实现均线模型。

3.自定义均线图

通过自定义的方式，我们就可以脱离quantmod包自由发挥了。我们首先需要自定义均线指标：

·日期时间序列为索引

·收盘价作为价格指标

·不考虑成交量以及其他维度字段

·取2010-01-01至2012-01-01的股票的行情数据

·画出价格曲线以及5日均线、20日均线、60日均线

用R语言程序实现代码，如下所示。

> ma<-function（cdata，mas=c（5，20，60））{ # 移动平均计算函数
+ ldata<-cdata
+ for（m in mas）{
+ ldata<-merge（ldata，SMA（cdata，m））
+ }
+ ldata<-na.locf（ldata， fromLast=TRUE）
+ names（ldata）<-c（'Value'，paste（'ma'，mas，sep=''））
+ return（ldata）
+ }
> drawLine<-function（ldata，titie="Stock_MA"，sDate=min（index（ldata）），eDate=
max（index（ldata）），out=FALSE）{ # 画出均线图
+ g<-ggplot（aes（x=Index， y=Value），data=fortify（ldata[，1]，melt=TRUE））
+ g<-g+geom_line（）
+ g<-g+geom_line（aes（colour=Series），data=fortify（ldata[，-1]，melt=TRUE））
+ g<-g+scale_x_date（labels=date_format（"%Y-%m"），breaks=date_breaks
（"2 months"），limits = c（sDate，eDate））
+ g<-g+xlab（""） + ylab（"Price"）+ggtitle（title）
+
+ if（out） ggsave（g，file=paste（titie，".png"，sep=""））
+ else g
+ }
# 运行程序
> cdata<-IBM['2010/2012']$Close # 取收盘价
> title<-"Stock_IBM" # 图片标题
> sDate<-as.Date（"2010-1-1"） # 开始日期
> eDate<-as.Date（"2012-1-1"） # 结束日期
> ldata<-ma（cdata，c（5，20，60）） # 选择滑动平均指标
> drawLine（ldata，title，sDate，eDate） # 画图，如图2-7所示

图2-7　均线图

通过自己封装的移动平均函数和可视化函数，就实现了与交易软件中类似的日K线图和多条均线结合的可视化输出。

4.一条均线的交易策略

基于上面的定义的均线函数，我们就可以设计自己的交易策略模型了。模型设计思路如下：

（1）以股价和20日均线的交叉，进行交易信号的判断。

（2）当股价上穿20日均线则买入，下穿20日均线则卖出。

画出股价和20日均线图，如图2-8所示。

> ldata<-ma（cdata，c（20）） # 选择滑动平均指标
> drawLine（ldata，title，sDate，eDate） # 画图

图2-8　20日均线图

以散点覆盖20日均线，红色点为买入持有，蓝色点为卖出空仓，如图2-9所示。

# 均线图+散点
> drawPoint<-function（ldata，pdata，titie，sDate，eDate）{
+ g<-ggplot（aes（x=Index， y=Value），data=fortify（ldata[，1]，melt=TRUE））
+ g<-g+geom_line（）
+ g<-g+geom_line（aes（colour=Series），data=fortify（ldata[，-1]，melt=TRUE））
+ g<-g+geom_point（aes（x=Index，y=Value，colour=Series），data=fortify（pdata，melt=TRUE））
+ g<-g+scale_x_date（labels=date_format（"%Y-%m"），breaks=date_breaks（"2 months"），
limits = c（sDate，eDate））
+ g<-g+xlab（""） + ylab（"Price"）+ggtitle（title）
+ g
+ }
# 散点数据
> pdata<-merge（ldata$ma20[which（ldata$Value-ldata$ma20>0）]，ldata$ma20[which
（ldata$Value-ldata$ma20<0）]）
> names（pdata）<-c（"down"，"up"）
> pdata<-fortify（pdata，melt=TRUE）
> pdata<-pdata[-which（is.na（pdata$Value）），]
> head（pdata）
Index Series Value
1 2010-01-04 down 128.7955
2 2010-01-05 down 128.7955
3 2010-01-06 down 128.7955
4 2010-01-07 down 128.7955
5 2010-01-08 down 128.7955
6 2010-01-11 down 128.7955
> drawPoint（ldata，pdata，title，sDate，eDate） # 画图，如图2-9所示

图2-9　20日均线交易信号图

用股价和20日均线价格做比较，把股价大于20日均线的部分用蓝色表示，股价小于20日均线的部分用红色表示。我们看到图中，蓝色点和红色点在20日均线上交替出现，我们可以在每次红色出现的第一个点买入股票，然后在蓝色出现的第一个点卖出股票，这样就构成了交易信号，从直观看上去的感觉还是不错的。

我们要找出这些交易信号点，做量化的统计，看看到底能不能赚钱，能赚多少钱。

> Signal<-function（cdata，pdata）{ # 交易信号
+ tmp<-''
+ tdata<-ddply（pdata[order（pdata$Index），]，.（Index，Series），function（row）{
+ if（row$Series==tmp） return（NULL）
+ tmp<<-row$Series
+ }）
+ tdata<-data.frame（cdata[tdata$Index]，op=ifelse（tdata$Series=='down'，'B'，'S'））
+ names（tdata）<-c（"Value"，"op"）
+ return（tdata）
+ }
> tdata<-Signal（cdata，pdata）
> tdata<-tdata[which（as.Date（row.names（tdata））<eDate），]
> head（tdata）
Value op
2010-01-04 132.45 B
2010-01-22 125.50 S
2010-02-17 126.33 B
2010-03-09 125.55 S
2010-03-11 127.60 B
2010-04-08 127.61 S
> nrow（tdata） # 交易记录
[1] 72

统计发现，一共有72条交易记录，买卖各占一半。

接下来，我们要利用交易信号的数据，进行模拟交易。我们设定交易参数，以10万美元为本金，满仓买入或卖出，手续费为0元。

# 模拟交易
> trade<-function（tdata，capital=100000，position=1，fee=0.00003）{
# 交易信号，本金，持仓比例，手续费比例
+ amount<-0 # 持股数量
+ cash<-capital # 现金
+
+ ticks<-data.frame（）
+ for（i in 1：nrow（tdata））{
+ row<-tdata[i，]
+ if（row$op=='B'）{
+ amount<-floor（cash/row$Value）
+ cash<-cash-amount*row$Value
+ }
+
+ if（row$op=='S'）{
+ cash<-cash+amount*row$Value
+ amount<-0
+ }
+
+ row$cash<-cash # 现金
+ row$amount<-amount # 持股数量
+ row$asset<-cash+amount*row$Value # 资产总值
+ ticks<-rbind（ticks，row）
+ }
+
+ ticks$diff<-c（0，diff（ticks$asset）） # 资产总值差
+
+ # 赚钱的操作
+ rise<-ticks[c（which（ticks$diff>0）-1，which（ticks$diff>0）），]
+ rise<-rise[order（row.names（rise）），]
+
+ # 赔钱的操作
+ fall<-ticks[c（which（ticks$diff<0）-1，which（ticks$diff<0）），]
+ fall<-fall[order（row.names（fall）），]
+
+ return（list（
+ ticks=ticks，
+ rise=rise，
+ fall=fall
+ ））
+ }
> result1<-trade（tdata，100000）
# 查看每笔交易
> head（result1$ticks）
Value op cash amount asset diff
2010-01-04 132.45 B 0.25 755 100000.00 0.00
2010-01-22 125.50 S 94752.75 0 94752.75 -5247.25
2010-02-17 126.33 B 5.25 750 94752.75 0.00
2010-03-09 125.55 S 94167.75 0 94167.75 -585.00
2010-03-11 127.60 B 126.55 737 94167.75 0.00
2010-04-08 127.61 S 94175.12 0 94175.12 7.37
# 盈利的交易
> head（result1$rise）
Value op cash amount asset diff
2010-03-11 127.60 B 126.55 737 94167.75 0.00
2010-04-08 127.61 S 94175.12 0 94175.12 7.37
2010-07-22 127.47 B 108.79 633 80797.30 0.00
2010-08-12 128.30 S 81322.69 0 81322.69 525.39
2010-09-09 126.36 B 120.40 632 79979.92 0.00
2010-11-16 142.24 S 90016.08 0 90016.08 10036.16
# 亏损的交易
> head（result1$fall）
Value op cash amount asset diff
2010-01-04 132.45 B 0.25 755 100000.00 0.00
2010-01-22 125.50 S 94752.75 0 94752.75 -5247.25
2010-02-17 126.33 B 5.25 750 94752.75 0.00
2010-03-09 125.55 S 94167.75 0 94167.75 -585.00
2010-04-09 128.76 B 51.56 731 94175.12 0.00
2010-04-12 128.36 S 93882.72 0 93882.72 -292.40

通过模拟交易，我们就能精确地算出每笔交易的盈利情况了。这其中，有56笔交易其实是亏损的，只有16笔交易是有盈利的。查看最后的资金情况。

> tail（result1$ticks，1）
Value op cash amount asset diff
2011-12-21 181.47 S 96363.76 0 96363.76 -3063.87

最后，资金剩余96363.76美元，也就是我们亏了3636.24美元。为什么最后会亏损呢？中间的大波段应该赚到了足够多的钱。通过资金曲线我们可以找到亏损的原因。画出资金曲线，如图2-10所示。

# 股价+现金流量
> drawCash<-function（ldata，adata）{
+ g<-ggplot（aes（x=Index， y=Value），data=fortify（ldata[，1]，melt=TRUE））
+ g<-g+geom_line（）
+ g<-g+geom_line（aes（x=as.Date（Index）， y=Value，colour=Series），data=fortify
（adata，melt=TRUE））
+ g<-g+facet_grid（Series ~ .，scales = "free_y"）
+ g<-g+scale_y_continuous（labels = dollar）
+ g<-g+scale_x_date（labels=date_format（"%Y-%m"），breaks=date_breaks（"2 months"），
limits = c（sDate，eDate））
+ g<-g+xlab（""） + ylab（"Price"）+ggtitle（title）
+ g
+ }
# 现金流量
> adata<-as.xts（result1$ticks[which（result1$ticks$op=='S'），]['cash']）
> drawCash（ldata，adata） # 画图

图2-10　20日均线策略现金曲线

我们把股价和现金流量并排放置，从2010-09开始均线策略开始大幅赚钱，到2011-10到达最高点，并且超过了本金，然后开始下滑，截至2012-01亏损3859.86美元。这是由于我们把赚到的利润继续投资，增大了头寸，以至于2011年年底的震荡市让模型失效，从而赔了更多的钱。

这样就完成一条20日均线的交易策略模型，并用IBM的股票做了测试。

5.二条均线的交易策略

一条均线模型，在大的趋势下是可以稳定赚钱的，但由于一条均线对于波动非常敏感，如果小波动过于频繁，不仅会增加交易次数，而且会让模型失效。然后，就有二条均线的策略模型，它可以降低对波动的敏感性。

二条均线策略模型，与一条均线模型思路类似，以5日均线价格替换股价，是通过5日均线和20日均线交叉来进行交易的。我们首先画出股价5日均线和20日均线图，如图2-11所示。

> ldata<-ma（cdata，c（5，20）） # 选择滑动平均指标
> drawLine（ldata，title，sDate，eDate） # 画图

图2-11　5日均线和20日均线图

以散点覆盖20日均线，红色点为买入持有，紫色点为卖出空仓，如图2-12所示。

# 散点数据
> pdata<-merge（ldata$ma20[which（ldata$ma5-ldata$ma20>0）]，ldata$ma20[which（ldata$ma5-
ldata$ma20<0）]）
> names（pdata）<-c（"down"，"up"）
> pdata<-fortify（pdata，melt=TRUE）
> pdata<-pdata[-which（is.na（pdata$Value）），]
> head（pdata）
Index Series Value
1 2010-01-04 down 128.7955
2 2010-01-05 down 128.7955
3 2010-01-06 down 128.7955
4 2010-01-07 down 128.7955
5 2010-01-08 down 128.7955
6 2010-01-11 down 128.7955
> drawPoint（ldata，pdata，title，sDate，eDate） # 画图，如图2-12所示。

图2-12　5日均线和20日均线交易信号图

用5日均线和20日均线价格做比较，把5日均线小于20日均线的部分用紫色表示，5日均线大于20日均线的部分用红色表示。我们看到图中，紫色点和红色点在20日均线上交替出现。同样，我们可以在每次红色出现的第一个点买入股票，然后在紫色出现的第一个点卖出股票。直观看上去与一条均线模型类似，都是赚钱的。

我们要找出这些交易信号点，做量化的统计，看看到底能不能赚钱。

> tdata<-Signal（cdata，pdata）
> tdata<-tdata[which（as.Date（row.names（tdata））<eDate），]
> head（tdata）
Value op
2010-01-04 132.45 B
2010-01-26 125.75 S
2010-02-18 127.81 B
2010-03-10 125.62 S
2010-03-16 128.67 B
2010-04-12 128.36 S
> nrow（tdata） # 交易记录
[1] 36

一共有36条交易记录，买卖各占一半，比一条均线模型少了36笔交易。

# 模拟交易
> result2<-trade（tdata，100000）
# 查看每笔交易
> head（result2$ticks）
Value op cash amount asset diff
2010-01-04 132.45 B 0.25 755 100000.00 0.00
2010-01-26 125.75 S 94941.50 0 94941.50 -5058.50
2010-02-18 127.81 B 106.48 742 94941.50 0.00
2010-03-10 125.62 S 93316.52 0 93316.52 -1624.98
2010-03-16 128.67 B 30.77 725 93316.52 0.00
2010-04-12 128.36 S 93091.77 0 93091.77 -224.75
# 盈利的交易
> head（result2$rise）
Value op cash amount asset diff
2010-09-10 127.99 B 75.34 649 83140.85 0.00
2010-11-18 144.36 S 93764.98 0 93764.98 10624.13
2010-12-07 144.02 B 2.66 638 91887.42 0.00
2011-02-23 160.18 S 102197.50 0 102197.50 10310.08
2011-03-28 161.37 B 124.70 582 94042.04 0.00
2011-05-20 170.16 S 99157.82 0 99157.82 5115.78
# 亏损的交易
> head（result2$fall）
Value op cash amount asset diff
2010-01-04 132.45 B 0.25 755 100000.00 0.00
2010-01-26 125.75 S 94941.50 0 94941.50 -5058.50
2010-02-18 127.81 B 106.48 742 94941.50 0.00
2010-03-10 125.62 S 93316.52 0 93316.52 -1624.98
2010-03-16 128.67 B 30.77 725 93316.52 0.00
2010-04-12 128.36 S 93091.77 0 93091.77 -224.75

通过模拟交易，我们精确地算出每笔交易的盈利情况了，有26笔交易是亏损的，16笔交易是有盈利的。

查看最后的资金情况。

> tail（result2$ticks，1）
Value op cash amount asset diff
2011-12-19 182.89 S 96828.9 0 96828.9 -3581.33

利用交易信号数据，进行模拟交易。我们设定交易参数，以100000美元为本金，满仓买入或卖出，手续费为0，传入交易信号。最后，资金剩余96828.9美元，亏了3171.1美元。查看资金曲线，如图2-13所示。

> adata<-as.xts（result2$ticks[which（result2$ticks$op=='S'），]['cash']）
> drawCash（ldata，adata）

图2-13　5日均线和20日均线策略现金曲线

我们可以发现，虽然最后资金也是赔了3171.1美元，比一条均线策略模型赔的少一点，但二条均线策略模型有3次高于本金的情况，而且最差的情况也比一条均线最差的情况要好。如果我们在获得盈利后，把赚到的钱从账户取出，只保持原来本金的继续交易，那么这部分利润就是可以锁定了。

6.对比两个模型的盈利情况

我们再进一步对比两个模型的盈利情况，找出两个模型中所有赚钱的交易。

# 盈利的交易
> rise<-merge（as.xts（result1$rise[1]），as.xts（result2$rise[1]））
> names（rise）<-c（"plan1"，"plan2"）
# 查看数据情况
> rise
plan1 plan2
2010-03-11 127.60 NA
2010-04-08 127.61 NA
2010-07-22 127.47 NA
2010-08-12 128.30 NA
2010-09-09 126.36 NA
2010-09-10 NA 127.99
2010-11-16 142.24 NA
2010-11-18 NA 144.36
2010-12-07 NA 144.02
2010-12-08 144.98 NA
2011-02-22 161.95 NA
2011-02-23 NA 160.18
2011-03-25 162.18 NA
2011-03-28 NA 161.37
2011-05-16 168.86 NA
2011-05-20 NA 170.16
2011-06-21 166.22 NA
2011-06-23 NA 166.12
2011-08-02 178.05 NA
2011-08-04 NA 171.48
2011-09-14 167.24 NA
2011-09-16 NA 172.99
2011-09-22 168.62 NA
2011-09-23 169.34 NA
2011-10-18 178.90 NA
2011-10-21 NA 181.63

plan1是一条均线模型，plan2是二条均线模型。plan1比plan2多了6次交易，但从中可以发现，多的这几次交易是由于对波动敏感性引起的，反而减少了趋势行情所带来的收益。

最后，我们画出2个模型盈利部分的交易区间。

> # 均线图+交易区间
> drawRange<-function（ldata，plan，titie="Stock_2014"，sDate=min（index（ldata）），
eDate=max（index（ldata）），out=FALSE）{
+ g<-ggplot（aes（x=Index， y=Value），data=fortify（ldata[，1]，melt=TRUE））
+ g<-g+geom_line（）
+ g<-g+geom_line（aes（colour=Series），data=fortify（ldata[，-1]，melt=TRUE））
+ g<-g+geom_rect（aes（NULL， NULL，xmin=start，xmax=end，fill=plan），ymin = yrng[1]，
ymax = yrng[2]，data=plan）
+ g<-g+scale_fill_manual（values =alpha（c（"blue"， "red"）， 0.2））
+ g<-g+scale_x_date（labels=date_format（"%Y-%m"），breaks=date_breaks
（"2 months"），limits = c（sDate，eDate））
+ g<-g+xlab（""） + ylab（"Price"）+ggtitle（title）
+
+ if（out） ggsave（g，file=paste（titie，".png"，sep=""））
+ else g
+ }
# 盈利区间
> yrng <-range（ldata$Value）
> plan1<-as.xts（result1$rise[c（1，2）]）
> plan1<-data.frame（start=as.Date（index（plan1）[which（plan1$op=='B'）]），end=
as.Date（index（plan1）[which（plan1$op=='S'）]），plan='plan1'）
> plan2<-as.xts（result2$rise[c（1，2）]）
> plan2<-data.frame（start=as.Date（index（plan2）[which（plan2$op=='B'）]），end=
as.Date（index（plan2）[which（plan2$op=='S'）]），plan='plan2'）
> plan<-rbind（plan1） # plan1的盈利区间
> drawRange（ldata，plan，title，sDate，eDate） # 画图

plan1的盈利区间，如图2-14所示。

> plan<-rbind（plan1，plan2） # 合并plan1和plan2的盈利区间
> drawRange（ldata，plan，title，sDate，eDate） # 画图

plan1和plan2同时存在的盈利区间，如图2-15所示。

图2-14　单均线策略的盈利区间

图2-15　双均线策略的盈利区间

从盈利区间我们可以看到，这印证了一条均线对波动敏感性的问题，二条均线模型是对一条均线模型的优化，这样我们就实现了一个完整均线模型的实例研发。

7.模型优化

从交易的角度讲，上面的模型还不能算完成，因为还有很多的赔钱交易，要进行更多地优化，减少最大回撤，在更确定的时机做多、反向做空等。模型优化的问题，会在《R的极客理想——量化投资篇》中再进行详细的介绍。

看起来均线模型是如此简单，但实盘交易时真能在趋势行情中跑赢双均线（优化）模型，也真不是一件容易的事情。二条均线打天下，不说是东方不败，也至少是独孤求败。

如果按照我所介绍的方法，赚到钱的朋友，可以请我喝杯茶，分享一下经验；没有赚到钱的朋友，还要继续努力，总有一天可以实现财富自由的目标的。

2.4　R语言中的遗传算法

问题

如何用R语言进行遗传算法的计算？

引言

人类总是在生活中摸索规律，把规律总结为经验，再把经验传给后人，让后人发现更多的规律，每一次知识的传递都是一次进化的过程，最终形成了人类的智慧。自然界的规律，让人类适者生存地活了下来，聪明的科学家又把生物进化的规律，总结成遗传算法，扩展到了更广的领域中。本节将带你走进遗传算法的世界。

2.4.1　遗传算法介绍

遗传算法是一种解决最优化的搜索算法，是进化算法的一种。进化算法最初借鉴了达尔文的进化论和孟德尔的遗传学说，从生物进化的一些现象发展起来，这些现象包括遗传、基因突变、自然选择和杂交等。遗传算法通过模仿自然界生物进化机制，发展出了随机全局搜索和优化的方法。它是一种高效、并行、全局搜索的方法，它能在搜索过程中自动获取和积累有关搜索空间的知识，并自适应地控制搜索过程，计算出全局最优解。

遗传算法的操作使用适者生存的原则，在潜在的种群中逐次产生一个近似最优解的方案，在每一代中，根据个体在问题域中的适应度值和从自然遗传学中借鉴来的再造方法进行个体选择，产生一个新的近似解。这个过程会导致种群中个体的进化，得到的新个体比原来个体更能适应环境，就像自然界中的改造一样。

如果从生物进化的角度，我们可以如下理解。在一个种群中，个体数量已经有一定规模，为了进化发展，通过选择和繁殖产生下一代的个体，其中繁殖过程包括交配和突变。根据适者生存的原则，选择过程会根据新个体的适应度进行保留或淘汰，但也不是完全以适应度高低作为导向，如果单纯选择适应度高的个体可能会产生局部最优的种群，而非全局最优，这个种群将不会再进化，称为早熟。之后，通过繁殖过程，让个体两两交配产生下一代新个体，上一代个体中优秀的基因会保留给下一代，而较差的基因将被个体另一半的基因所代替。最后，通过小概率事件发生基因突变，通过突变产生新的下一代个体，实现种群的变异进化。

经过这一系列的选择、交配和突变的过程，产生的新一代个体将不同于初始的一代，并一代一代向增加整体适应度的方向发展，因为最好的个体总是更多地被选择去产生下一代，而适应度低的个体逐渐被淘汰掉。这样的过程不断地重复：每个个体被评价，计算出适应度，两个个体交配，然后突变，产生第三代。周而复始，直到终止条件满足为止。

遗传算法使用需要注意很多问题。

（1）遗传算法在适应度函数选择不当的情况下有可能收敛于局部最优，而不能达到全局最优。

（2）初始种群的数量很重要，如果初始种群数量过多，算法会占用大量系统资源；如果初始种群数量过少，算法很可能忽略掉最优解。

（3）对于每个解，一般根据实际情况进行编码，这样有利于编写变异函数和适应度函数。

（4）在编码过的遗传算法中，每次变异的编码长度也影响到遗传算法的效率。如果变异代码长度过长，变异的多样性会受到限制；如果变异代码过短，变异的效率会非常低下，选择适当的变异长度是提高效率的关键。

（5）变异率是一个重要的参数。

（6）对于动态数据，用遗传算法求最优解比较困难，因为染色体种群很可能过早地收敛，而对以后变化了的数据不再产生变化。对于这个问题，研究者提出了一些方法增加基因的多样性，从而防止过早收敛。其中一种是所谓触发式超级变异，就是当染色体群体的质量下降（彼此的区别减少）时增加变异概率；另一种叫随机外来染色体，是偶尔加入一些全新的随机生成的染色体个体，从而增加染色体多样性。

（7）选择过程很重要，但交叉和变异的重要性存在争议。一种观点认为交叉比变异更重要，因为变异仅仅是保证不丢失某些可能的解；而另一种观点则认为交叉过程的作用只不过是在种群中推广变异过程所造成的更新，对于初期的种群来说，交叉几乎等效于一个非常大的变异率，而这么大的变异很可能影响进化过程。

（8）遗传算法很快就能找到良好的解，即使是在很复杂的解空间中。

（9）遗传算法并不一定总是最好的优化策略，优化问题要具体情况具体分析。所以在使用遗传算法的同时，也可以尝试其他算法，互相补充，甚至根本不用遗传算法。

（10）遗传算法不能解决那些“大海捞针”的问题，所谓“大海捞针”问题就是没有一个确切的适应度函数表征个体好坏的问题，使得算法的进化失去导向。

（11）对于任何一个具体的优化问题，调节遗传算法的参数可能会有利于更好、更快地收敛，这些参数包括个体数目、交叉率和变异率。例如，太大的变异率会导致丢失最优解，而过小的变异率会导致算法过早收敛于局部最优解。对于这些参数的选择，现在还没有实用的上下限。

（12）适应度函数对于算法的速度和效果也很重要。

遗传算法的应用领域包括计算机自动设计、生产调度、电路设计、游戏设计、机器人学习、模糊控制、时间表安排、神经网络训练等。然而，我准备把遗传算法应用到金融领域，比如回测系统的参数寻优方案，我会在《R的极客理想——量化投资篇》中介绍有关金融领域的算法解决方案。

2.4.2　遗传算法原理

在遗传算法里，优化问题的解被称为个体，它表示为一个变量序列，叫做染色体或者基因串。染色体一般被表达为简单的字符串或数字串，也有其他表示法，这一过程称为编码。首先要创建种群，算法随机生成一定数量的个体，有时候也可以人工干预这个过程进行，以提高初始种群的质量。在每一代中，每一个个体都被评价，并通过计算适应度函数得到一个适应度数值。种群中的个体被按照适应度排序，适应度高的在前面。

接下来，是产生下一代个体的种群，通过选择过程和繁殖过程完成。

选择过程是根据新个体的适应度进行的，但同时并不意味着完全的以适应度高低作为导向，因为单纯选择适应度高的个体将可能导致算法快速收敛到局部最优解而非全局最优解，我们称之为早熟。作为折中，遗传算法依据原则：适应度越高，被选择的机会越高，而适应度低的，被选择的机会就低。初始的数据可以通过这样的选择过程组成一个相对优化的群体。

繁殖过程表示被选择的个体进入交配过程，包括交配（crossover）和突变（mutation），交配对应算法中的交叉操作。一般的遗传算法都有一个交配概率，范围一般是0.6~1，这个交配概率反映两个被选中的个体进行交配的概率。例如，交配概率为0.8，则80%的“夫妻”个体会生育后代。每两个个体通过交配产生两个新个体，代替原来的“老”个体，而不交配的个体则保持不变。交配过程，父母的染色体相互交换，从而产生两个新的染色体，第一个个体前半段是父亲的染色体，后半段是母亲的，第二个个体则正好相反。不过这里指的半段并不是真正的一半，分段的位置叫做交配点，也是随机产生的，可以是染色体的任意位置。

突变过程，表示通过突变产生新的下一代个体。一般遗传算法都有一个固定的突变常数，又称为变异概率，通常是0.1或者更小，这代表变异发生的概率。根据这个概率，新个体的染色体随机地突变，通常就是改变染色体的一个字节（0变到1，或者1变到0）。

遗传算法实现将不断地重复这个过程：每个个体被评价，计算出适应度，两个个体交配，然后突变，产生下一代，直到终止条件满足为止。一般终止条件有以下几种：

·进化次数限制。

·计算耗费的资源限制，如计算时间、计算占用的CPU、内存等。

·个体已经满足最优值的条件，即最优值已经找到。

·当适应度已经达到饱和，继续进化不会产生适应度更好的个体。

·人为干预。

图2-16　遗传算法实现思路

算法实现思路，如图2-16所示。在图2-16中，算法实现过程为：

（1）创建初始种群

（2）循环：产生下一代

（3）评价种群中的个体适应度

（4）定义选择的适应度函数

（5）改变该种群（交配和变异）

（6）返回第二步

（7）满足终止条件结束

2.4.3　R语言中的遗传算法

本节的系统环境是：

·Windows 7 64bit

·R：3.1.1 x86_64-w64-mingw32/x64（64-bit）

一个典型的遗传算法要求一个基因表示的求解域，以及一个适应度函数来评价解决方案。

遗传算法的参数，通常包括以下几个。

·种群规模（Population），即种群中染色体个体的数目。

·染色体的基因个数（Size），即变量的数目。

·交配概率（Crossover），用于控制交叉计算的使用频率。交叉操作可以加快收敛，使解达到最有希望的最优解区域，因此一般取较大的交叉概率，但交叉概率太高也可能导致过早收敛。

·变异概率（Mutation），用于控制变异计算的使用频率，决定了遗传算法的局部搜索能力。

·中止条件（Termination），结束的标志。

在R语言中，有一些现成的第三方包已经实现的遗传算法，我们可以直接使用。

·mcga包，多变量的遗传算法，用于求解多维函数的最小值，在大范围的搜索空间中，效率非常高。

·genalg包，多变量的遗传算法，用于求解多维函数的最小值，提供数据可视化的功能。

·rgenoud包，复杂的遗传算法，将遗传算法和衍生的拟牛顿算法结合起来，可以求解复杂函数的最优化化问题。

·gafit包，利用遗传算法求解一维函数的最小值。不支持R 3.1.1的版本。

·GALGO包，利用遗传算法求解多维函数的最优化解。不支持R 3.1.1的版本。

本节将介绍mcga包和genalg包的遗传算法的使用。

1.mcga包

我们使用mcga包的mcga（）函数，可以实现多变量的遗传算法。mcga包是一个遗传算法的工具包，主要解决实值优化的问题。它使用变量值表示基因序列，而不是字节码，因此不需要编解码的处理。mcga实现了遗传算法的交配和突变的操作，并且可以进行大范围和高精度的搜索空间的计算，算法的主要缺点是使用了256位的一元字母表。首先，安装mcga包。

> install.packages（"mcga"）
> library（mcga）

查看mcga（）函数的定义。

> mcga
function （popsize， chsize， crossprob = 1， mutateprob = 0.01， elitism = 1， minval，
maxval， maxiter = 10， evalFunc）

其中各参数意义如下：popsize是个体数量，即染色体数目；chsize是基因数量，限参数的数量；crossprob是交配概率，默认为1.0；mutateprob是突变概率，默认为0.01；elitism是精英数量，直接复制到下一代的染色体数目，默认为1；minval是随机生成初始种群的下边界值；maxval是随机生成初始种群的上边界值；maxiter是繁殖次数，即循环次数，默认为10；evalFunc是适应度函数，用于给个体进行评价。

接下来，我们给出一个优化的问题，通过mcga（）函数，计算最优化的解。

题目1：设f（x）=（x_1-5）2+（x_2-55）2+（x_3-555）2+（x_4-5555）2+（x_5-55555）2，计算f（x）的最小值，其中x_1，x_2，x_3，x_4，x_5为5个不同的变量。

从直观上看，如果想得到f（x）的最小值，其实当x_1=5，x_2=55，x_3=555，x_4=5555，x_5=55555时，f（x）=0为最小值。如果使用穷举法，通过循环的方法找到这5个变量估计会很费时，这里就不做测试了。下面我们看看遗传算法的运行情况。

# 定义适应度函数
> f<-function（x）{
return （（x[1]-5）^2 + （x[2]-55）^2 +（x[3]-555）^2 +（x[4]-5555）^2 +（x[5]-55555）^2）
}
# 运行遗传算法
> m <- mcga（ popsize=200，
+ chsize=5，
+ minval=0.0，
+ maxval=999999，
+ maxiter=2500，
+ crossprob=1.0，
+ mutateprob=0.01，
+ evalFunc=f）
# 最优化的个体结果
> print（m$population[1，]）
[1] 5.000317 54.997099 554.999873 5555.003120 55554.218695
# 执行时间
> m$costs[1]
[1] 3.6104556

我们得到的最优化的结果为x_1=5.000317，x_2=54.997099，x_3=554.999873，x_4=5555.003120，x_5=55554.218695，和我们预期的结果非常接近，而且耗时只有3.6秒。这个结果是非常令人满意的。而如果使用穷举法，时间复杂度为O（n^5），估计没有5分钟肯定算不出来。

当然，算法执行的时间和精度，都是通过参数进行配置的。如果增大个体数目或循环次数，一方面会增加算法的计算时间，另一方面结果也可能变得更精准。所以，在实际的使用过程中，需要根据一定的经验调整这几个参数。

2.genalg包

我们使用genalg包的rbga（）函数，也可以实现多变量的遗传算法。genalg包不仅实现了遗传算法，还提供了遗传算法的数据可视化，让用户从更直观的角度理解算法。genalg包会生成默认的可视化图，包括每次迭代的最优评价值，表示遗传算法的计算进度。直方图显出了基因选择的频率，即基因在当前个体中被选择的次数。参数图表示评价函数和变量值，非常方便地看到评价函数和变量值的相关关系。

首先，安装genalg包。

> install.packages（"genalg"）
> library（genalg）

查看rbga（）函数的定义。

> rbga（stringMin=c（）， stringMax=c（），
suggestions=NULL，
popSize=200， iters=100，
mutationChance=NA，
elitism=NA，
monitorFunc=NULL， evalFunc=NULL，
showSettings=FALSE， verbose=FALSE）

参数说明：

·stringMin，设置每个基因的最小值。

·stringMax，设置每个基因的最大值。

·suggestions，建议染色体的可选列表。

·popSize，个体数量，即染色体数目，默认为200。

·iters，迭代次数，默认为100。

·mutationChance，突变机会，默认为1/（size+1），它影响收敛速度和搜索空间的探测，低机率导致更快收敛，高机率增加了搜索空间的跨度。

·elitism，精英数量，默认为20%，直接复制到下一代的染色体数目。

·monitorFunc，监控函数，每产生一代后运行。

·evalFunc，适应度函数，用于给个体进行评价。

·showSettings，打印设置，默认为false。

·verbose，打印算法运行日志，默认为false。

接下来，我们给定一个优化的问题，通过rbga（）函数，计算最优化的解。

题目2：设，计算f（x）的最小值，其中x_1，x_2为2个不同的变量。

从直观上看，如果想得到f（x）的最小值，其实当x_1==1.648721，x_2=lnπ=1.14473时，f（x）=0为最小值。同样，如果使用穷举法，通过循环的方法找到这2个变量，估计会很费时的，我也不做测试了。下面我们看看rbga（）函数的遗传算法的运行情况。

# 定义适应度函数
> f<-function（x）{
return （abs（x[1]-sqrt（exp（1）））+abs（x[2]-log（pi）））
}
# 定义监控函数
> monitor <- function（obj）{
xlim = c（obj$stringMin[1]， obj$stringMax[1]）；
ylim = c（obj$stringMin[2]， obj$stringMax[2]）；
plot（obj$population， xlim=xlim， ylim=ylim， xlab="sqrt（exp（1））"， ylab="log（pi）"）；
}
# 运行遗传算法
> m2 = rbga（c（1，1），
+ c（3，3），
+ popSize=100，
+ iters=1000，
+ evalFunc=f，
+ mutationChance=0.01，
+ verbose=TRUE，
+ monitorFunc=monitor
+ ）
Testing the sanity of parameters...
Not showing GA settings...
Starting with random values in the given domains...
Starting iteration 1
Calucating evaluation values... .......................................... done.
Sending current state to rgba.monitor（）...
Creating next generation...
sorting results...
applying elitism...
applying crossover...
applying mutations... 2 mutations applied
Starting iteration 2
Calucating evaluation values... ...................... done.
Sending current state to rgba.monitor（）...
Creating next generation...
sorting results...
applying elitism...
applying crossover...
applying mutations... 4 mutations applied
Starting iteration 3
Calucating evaluation values... ....................... done.
# 省略输出...

程序运行截图，如图2-17所示。

图2-17　rbga（）函数的算法执行

需要注意的是，程序在要命令行中运行，如果在RStudio中运行，会出现下面的错误提示。

Error in get（name， envir = asNamespace（pkg）， inherits = FALSE） ：
object 'rversion' not found
Graphics error： Error in get（name， envir = asNamespace（pkg）， inherits = FALSE） ：
object 'rversion' not found

我们迭代1000次后，查看计算结果。

# 计算结果
> m2$population[1，]
[1] 1.650571 1.145784

得到的最优化的结果为x_1=1.650571，x_2=1.145784，非常接近最终的结果。另外，我们可以通过genalg包的可视化功能，看到迭代过程的每次的计算结果。下面截图分别对应第1次迭代、第10次迭代、第200次迭代和第1000次迭代的计算结果。从图2-18中可以看出，随着迭代次数的增加，优选出的结果集变得越来越少，而且越来越精准。

除了可以对算法进行可视追踪，rbga包还提供了3个用于分析效果的可视化图表，分别是默认图、直方图和参数图。用R实现默认图的输出，如图2-19所示。

> plot（m2）

默认图用于描述遗传过程的进展情况，X轴为迭代次数，Y轴为评价值，评价值越接近于0越好。在迭代1000次后，基本找到了精确的结果。

用R实现直方图输出，如图2-20所示。

> plot（m2，type='hist'）

图2-18　遗传算法的数据可视化

直方图用于描述对染色体的基因选择频率，即一个基因在染色体中被选择的次数。当变量x_1在1.65区域时，被选择超过80次；当变量x_2在1.146区域时，被选择超过了80次。通过直方图，我们可以看出更优秀的基因被留给了后代。

图2-19　默认图输出

图2-20　直方图输出

用R实现参数图输出，如图2-21所示。

> plot（m2，type='vars'）

参数图用于描述评价函数和变量的值之间的相关关系。对于变量x_1，评价值越小，变量值越准确，能大概看出相关关系，但相关关系不明显。对于x_2，看不出相关关系。

图2-21　参数图输出

对比mcga包和genalg包，mcga包适合计算大范围取值空间的最优解，而用genalg包对于大范围取值空间的计算表现就不太好了。从另一个方面讲，genalg包提供了可视化工具，可以让我们直观地看到遗传算法的收敛过程，对于算法的理解和调优是非常有帮助的。

在掌握了遗传算法后，我们就可以快度地处理一些优化的问题了，在《R的极客理想——量化投资篇》中，我会介绍金融回测系统的参数寻优方案。让我们远离穷举法，珍惜CPU的每一秒时间。

本节参考了文章：Wiki遗传算法（http://zh.wikipedia.org/zh/遗传算法）。

第二部分　深入R语言程序开发

■第3章　R内核编程

■第4章　面向对象编程

第3章　R内核编程

本章主要介绍了R语言内核相关的编程，通过pryr包了解R语言底层的特性，了解R语言环境空间的定义及函数环境空间的使用，掌握R语言文件系统的管理，以及R语言3.1版本新特性的解读，从而帮助读者学习R语言的底层知识。

3.1　撬动R内核的高级工具包pryr

问题

怎么了解R的内部运行原理？

引言

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

3.1.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、<<-

3.1.2　pryr安装

本节使用的系统环境是：

·Linux：Ubuntu Server 12.04.2 LTS 64bit

·R：3.1.1 x86_64-pc-linux-gnu（64-bit）

注　pryr同时支持Windows 7环境和Linux环境。

安装pryr包时，可以直接通过CRAN下载，也可以通过Github来安装。直接用CRAN下载安装pryr包。

~ R # 启动R程序
> install.packages（pryr） # 安装pryr
> library（pryr）

从Github安装pryr包需要devtools包配合，devtools的详细安装说明和使用，请参考5.2节。通过github安装pryr包。

~ R # 启动R程序
> library（devtools） # 加载devtools
> install_github（"pryr"） # 通过devtools工具安装pryr
> library（pryr）

3.1.3　pryr使用

接下来，我们将看到pryr包中各种函数的使用。

1.创建匿名函数f（）

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

> f（x + y） # 创建一个匿名函数
function （x， y）
x + y
> f（x + y）（1， 10） # 创建一个匿名函数，并赋值计算
[1] 11
> f（x， y = 2， x + y） # 创建一个匿名函数，指定参数x和参数y的默认值为2
function （x， y = 2）
x + y
> f（x， y = 2， x + y）（1） # 创建一个匿名函数，指定参数x和参数y的默认值为2，并赋值计算
[1] 3
> f（{y <- runif（1）； x + y}）（3） # 创建一个多行运算的匿名函数，并赋值计算
[1] 3.7483

2.通过参数创建函数make_function（）

通过给make_function（）函数传递不同的参数，可以实现动态地创建一个函数，而不需要像原来一样的function（）赋值的语法，这样做的好处是在运行时动态生成函数，并和环境绑定，同时减少静态代码量。

查看make_function（）函数的定义，make_function（）函数有3个参数。

make_function（args， body， env = parent.frame（））

其中参数args用于生成函数的参数部分，list类型；body用于生成函数的表达式部分，语法表达式，call类型；env用于生成函数的系统环境部分，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.创建匿名函数调用partial（）

使用partial（）函数，可以减少参数定义的过程，方便匿名函数的调用，具体应用代码如下。

> compact1 <- function（x） Filter（Negate（is.null）， x） # 定义一个普通的函数
> compact1
function（x） Filter（Negate（is.null）， x）
> compact2 <- partial（Filter， Negate（is.null）） # 通过partial定义的匿名函数
> 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
> f2 <- partial（runif， n = rpois（1， 5）） # 通过partial的匿名函数调用
> f2（）
[1] 0.25955143 0.12858459 0.04994997 0.11505708 0.10509429
> f2（）
[1] 0.9710866 0.1469317

4.变量表达式替换substitute_q（），subs（）

使用substitute_q（）函数，可以对表达式调用，直接进行参数替换。

> x <- quote（a + b） # 定义一个表达式调用
> class（x）
[1] "call"
> substitute（x， list（a = 1， b = 2）） # 对x调用参数替换，无效
x
> substitute（a+b， list（a = 1， b = 2）） # 对直接变量参数替换
1 + 2
> substitute_q（x， list（a = 1， b = 2）） # 对x调用参数替换
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

5.面向对象类型判断otype（），ftype（）

要判断对象类型，base包默认提供的几个函数实在不好用。通过pryr包的otype（）函数可以很容易地分辨出S3类型、S4类型、RC类型的对象，比起内置的类型检查要高效得多。

> otype（1：10） # 基本类型
[1] "primitive"
> otype（c（'a'，'d'））
[1] "primitive"
> otype（list（c（'a'），data.frame（）））
[1] "primitive"
> otype（data.frame（）） # S3类型
[1] "S3"
> x <- 1 # 自定义的S3类型
> attr（x，'class'）<-'foo'
> is.object（x）
[1] TRUE
> otype（x）
[1] "S3"
> setClass（"Person"，slots=list（name="character"，age="numeric"）） # S4类型
> alice<-new（"Person"，name="Alice"，age=40）
> isS4（alice）
[1] TRUE
> otype（alice）
[1] "S4"
> Account<-setRefClass（"Account"） # RC类型
> 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"
> ftype（sum） # primitive函数
[1] "primitive" "generic"
> ftype（writeLines） # internal函数
[1] "internal"
> ftype（unlist）
[1] "internal" "generic"
> ftype（t.data.frame） # S3函数
[1] "s3" "method"
> ftype（t.test）
[1] "s3" "generic"
> setGeneric（"union"） # S4函数
[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"
> Account<-setRefClass（"Account"， # RC函数
+ 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"

6.查看对象底层的C语言类型address（），refs（），typename（）

我们可以通过address（）、refs（）、typename（）来查看R对象对应的底层C语言实现的类型。其中typename（）返回C语言类型名，address（）返回内存地址，refs（）返回指针数字。查看变量的C语言类型，代码如下。

> x <- 1：10 # 定义一个变量x
> typename（x） # 打印C语言类型名
[1] "INTSXP"
> refs（x） # 返回指针
[1] 1
> address（x） # 打印内存地址
[1] "0x365f560"
> z <- list（1：10） # 定义一个list对象
> typename（z） # 打印C语言类型名
[1] "VECSXP"
> delayedAssign（"a"， 1 + 2） # 延迟赋值
> typename（a） # 打印C语言类型名
[1] "PROMSXP"
> a # 打印a变量
[1] 3
> typename（a）
[1] "PROMSXP"
> b<-3 # 定义变量b，与a变量对比
> typename（b）
[1] "REALSXP"

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"
> track_a（） # 检查变量是否被修改，已被修改
a copied

8.查看闭包函数变量unenclose（）

使用unenclose（）给闭包环境的变量赋值。

> power <- function（exp） { # 定义一个嵌套函数power
+ function（x） x ^ exp
+ }
> square <- power（2） # 调用闭包函数
> cube <- power（3）
> square # 查看square函数，exp变量并没有显示赋值后的结果
function（x） x ^ exp
<environment： 0x4055f28>
> unenclose（square） # 查看square函数，exp变量显示赋值后的结果
function （x）
x^2
> square（3） # 执行square函数
[1] 9

9.批量修改对象modify_lang（）

这是一个神奇的函数，可以方便地替换list对象、表达式、函数中的变量定义。接下来，我们尝试替换list对象中定义的变量a为变量b。

> examples <- list（ # 定义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 <- function（x） { # 定义转换函数a_to_b，
+ if （is.name（x） && identical（x， quote（a））） return（quote（b））
+ x
+ }
> modify_lang（examples， a_to_b） # 批量修改对象，将examples对象中所有的变量a替换成变量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））

10.快速创建list对象dots（），named_dots（）

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

> y <- 2 # 初始化一个变量
> dots（x = 1， y， z = ） # 创建list对象
$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来得到值。

> named_dots（x = 1， y， z =） # 创建list对象
$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

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 # 查看Map函数，检查是否包括match.fun字符串
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 # 查看ave函数源代码，检查参数名是否有FUN字符串
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>

12.查询环境变量where（），rls（），parenv（）

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

> x <- 1 # 定义一个变量x
> where（"x"） # 查找x变量的环境空间
<environment： R_GlobalEnv>
> where（"t.test"） # 查询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>
> where（"mean"） # 查询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（）函数，可以显示出当前环境的所有变量，包括当前环境变量、全局环境变量、空环境变量（the empty environment）、命名空间环境变量。

> 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（）函数，可以找到函数调用的上一级环境，从而可以追溯到函数的根。

> adder <- function（x） function（y） function（z） x + y + z # 定义一个3层嵌套函数
> 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>

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

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

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

> x <- 10 # 定义变量并赋值
> is_promise（x） # 检查是否 promise模式
[1] FALSE
> （function（x） is_promise（x））（x = 10） # 匿名函数调用，检查是否 promise模式
[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

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 <- 1 # 对已知变量a重新赋值
> rebind（"a"， 2）
> rebind（"ccc"， 2） # 对未知变量ccc重新赋值，出错
Error： Can't find ccc
> a<<-2 # 用 <<- 对已知变量a重新赋值
> a
[1] 2
> rm（ccc） # 删除变量ccc
> ccc
Error： object 'ccc' not found
> ccc<<-2 # 用 <<- 对未知变量ccc重新赋值
> ccc
[1] 2

通过对pryr全面介绍，我们了解这个包的强大，对于R的运行原理和数据结构的理解非常有帮助，这是深入R内核之前我们必修的一课。

3.2　揭开R语言中环境空间的神秘面纱

问题

R语言中的环境空间怎么用？

引言

对于大部分的R使用者来说，环境空间都是比较陌生的。虽然我们不了解它的运行原理，但也不影响我们使用R语言。环境空间是R语言中关于计算机方面的底层设计，主要用于R语言的环境加载器。通过环境空间，封装了加载器的运行过程，让使用者在不知道底层细节的情况下，可以任意加载使用到的第三方R语言程序包。本节将揭开R语言中环境空间的神秘面纱。

3.2.1　R语言的环境空间

在R语言中，不管是变量、对象或者函数，都存在于R的环境空间中，R程序在运行时变量、函数都有自己的运行时空间。R语言的环境（environment）是由内核定义的一个数据结构，由一系列、有层次关系的框架（frame）组成，每个环境对应一个框架，用来区别不同的运行时空间（scope）。

环境空间有一些特征，比如每个环境空间要有唯一的名字；环境空间是引用类型，非赋值类型；环境空间都有父环境空间，空环境空间是最顶层的环境空间，没有父空间；子环境空间会继承父环境空间的变量等。

本节的系统环境是：

·Linux：Ubuntu Server 12.04.2 LTS 64bit

·R：3.1.1 x86_64-pc-linux-gnu（64-bit）

为了方便我们检查环境空间的层次关系，引入pryr包作为辅助工具，关于pryr包的详细介绍，请参考3.1节。

> library（pryr） # 加载pryr包

1.创建一个环境

通过new.env（）函数可以创建一个新的环境。查看new.env（）函数的定义。

new.env（hash = TRUE， parent = parent.frame（）， size = 29L）

参数列表：

·hash默认值是TRUE，使用Hash table的结构。

·parent指定要创建环境的父环境。

·size，初始化的环境空间大小。

运行函数new.env（），创建一个新环境。

> e1 <- new.env（） # 创建环境e1
> e1 # 输出e1
<environment： 0x3d7eef0>
> class（e1） # 查看e1类型
[1] "environment"
> otype（e1） # otype查看e1类型，属于基本类型
[1] "primitive"

接下来，我们在e1环境中定义一个变量。

> e1$a <- 10 # 定义变量a
> e1$a # 输出变量a
[1] 10
> ls（） # 列出当前环境中的变量
[1] "e1"
> ls（e1） # 列出e1环境中的变量
[1] "a"

这时，我们看到两个环境空间：当前环境空间和e1环境空间。e1作为一个变量在当前的环境中被定义，变量a在e1环境中被定义。

2.环境空间的层次结构

R语言的环境空间是一种有层次关系的结构，每个环境都有上一层环境，直到最顶层的空环境。R语言中有5种环境的定义，即全局环境、内部环境、父环境、空环境和包环境。

·全局环境，即用户环境，是用户程序运行的环境空间。

·内部环境，构造出来的环境，可以是通过new.env（）函数显示创建的环境空间，也可以是匿名的环境空间。

·父环境，即上一层环境，环境空间的上一层。

·空环境，即顶层环境，没有父环境空间。

·包环境，包封装的环境空间。

> environment（） # 当前环境
<environment： R_GlobalEnv>
> e1 <- new.env（） # 内部环境
> e1
<environment： 0x3e28948>
> parent.env（e1） # 父环境
<environment： R_GlobalEnv>
> emptyenv（） # 空环境
<environment： R_EmptyEnv>
> baseenv（） # 包环境
<environment： base>

可以用search（）函数查看当前环境中加载的R包。

> search（） # 查看环境空间
[1] ".GlobalEnv" "package：pryr" "package：stats"
[4] "package：graphics" "package：grDevices" "package：utils"
[7] "package：datasets" "package：methods" "Autoloads"
[10] "package：base"
> .GlobalEnv # 当前的环境空间
<environment： R_GlobalEnv>
> parent.frame（）
<environment： R_GlobalEnv>

查看父环境空间。

> parent.env（e1） # e1环境的父环境空间
<environment： R_GlobalEnv>
> parent.env（environment（）） # 当前环境的父环境空间
<environment： package：pryr>
attr（，"name"）
[1] "package：pryr"
attr（，"path"）
[1] "/home/conan/R/x86_64-pc-linux-gnu-library/3.0/pryr"
> parent.env（baseenv（）） # base包环境的父环境空间
<environment： R_EmptyEnv>
> parent.env（emptyenv（）） # 空环境的父环境空间，因没有父环境，所以出现错误
Error in parent.env（emptyenv（）） ： the empty environment has no parent

既然环境空间是有层次关系的，那么我们打印这个层次结构，从自定义的e1环境到最上层的空环境。

> parent.call<-function（e）{ # 递归打印父环境空间
+ print（e）
+ if（is.environment（e） & ！identical（emptyenv（），e））{
+ parent.call（parent.env（e））
+ }
+ }
> parent.call（e1） # 运行函数
<environment： 0x366bf18>
<environment： R_GlobalEnv>
<environment： package：pryr>
attr（，"name"）
[1] "package：pryr"
attr（，"path"）
[1] "/home/conan/R/x86_64-pc-linux-gnu-library/3.0/pryr"
<environment： package：stats>
attr（，"name"）
[1] "package：stats"
attr（，"path"）
[1] "/usr/lib/R/library/stats"
<environment： package：graphics>
attr（，"name"）
[1] "package：graphics"
attr（，"path"）
[1] "/usr/lib/R/library/graphics"
<environment： package：grDevices>
attr（，"name"）
[1] "package：grDevices"
attr（，"path"）
[1] "/usr/lib/R/library/grDevices"
<environment： package：utils>
attr（，"name"）
[1] "package：utils"
attr（，"path"）
[1] "/usr/lib/R/library/utils"
<environment： package：datasets>
attr（，"name"）
[1] "package：datasets"
attr（，"path"）
[1] "/usr/lib/R/library/datasets"
<environment： package：methods>
attr（，"name"）
[1] "package：methods"
attr（，"path"）
[1] "/usr/lib/R/library/methods"
<environment： 0x20cb5d0>
attr（，"name"）
[1] "Autoloads"
<environment： base>
<environment： R_EmptyEnv>

通过递归查找父环境空间，我们看到整个环境空间的层次结构，如图3-1所示。

通过图3-1中的环境空间层次结构图，我们还可以发现R包的加载顺序。最先加载的是base包，然后通过base：：Autoloads（）函数分别加载6个基础包，上层的pryr包则是笔者手动加载的，最后以R_GlobalEnv环境作为当前运行环境空间，内部环境空间是R_GlobalEnv环境的下层环境空间。

图3-1　环境空间层次结构图

3.2.2　环境空间的特征

上面提到环境空间有一些特征，下面我们分别介绍。

1.每个环境空间中的对象名字要唯一

在当前环境空间中定义变量名x，并对x进行操作。

> x<-10；x # 定义变量x
[1] 10
> address（x） # 查看x地址
[1] "0x2874068"
> x<-11；x # 对x改变赋值
[1] 11
> address（x） # 查看x地址
[1] "0x28744c8"

这样我们可以看到，x变量在每次赋值的时候，内存地址都会发生改变，但是x的名字还是x。下面在不同的环境空间中，再定义一个变量x。

> e1<-new.env（） # 创建环境空间e1
> e1$x<-20 # 在e1中定义变量x
> x；e1$x # 输出x
[1] 12
[1] 20

在不同的环境空间中，可以有同名的变量出现，而同一个环境空间中，不能有同名的变量。

2.环境空间变量的赋值

如果把e1环境空间变量赋值给另一个变量f，再修改其环境内部变量，会是什么结果呢？

> f <- e1 # 把e1赋值给f
> e1$a <- 1111 # 修改e1中a变量的值
> f$a # 查看f环境空间的a值
[1] 1111
> identical（f，e1） # 比较f环境和e1环境，是相等的
[1] TRUE
> e1 # 查看e1和f的环境地址，是完全相同的
<environment： 0x3e28948>
> f
<environment： 0x3e28948>

从上面的运行结果可以看出，环境空间的赋值是一种引入的传递，并不会新创建一个环境空间变量。

3.定义更上层的环境空间

空环境是最顶层的环境空间，然后是base包的环境空间，我们可以尝试创建一个靠近顶层的环境空间，让父环境空间是base包的环境空间。

> e2 <- new.env（parent = baseenv（））；e2 # 创建e2环境，以base为父环境
<environment： 0x37cab18>
> parent.call（e2） # 查看e2环境的父环境列表
<environment： 0x37cab18>
<environment： base>
<environment： R_EmptyEnv>

这样e2环境空间就位于环境空间中的第三层了。

4.子环境空间会继承父环境空间的变量

在当前环境中定义一个变量x，在子环境e1中对x重新赋值。

> x<-1：5 # 在当前环境定义变量x
> e1 <- new.env（ # 新建环境空间e1
> e1$x<-1 # e1环境空间中定义变量x
> e1$fun<-function（y）{ # 在e1环境空间中定义函数，并对父环境空间的x变量重新赋值
+ print（'e1：：fun'）
+ x<<-y
+ }
> e1$fun（50） # 运行e1环境空间中的函数，将x赋值为50
[1] "e1：：fun"
> x # 当前环境x变量被修改
[1] 50
> e1$x # e1环境x变量没有变化
[1] 1

如果想修改父环境空间的变量值，我们就需要用到<<-赋值符号了，很多朋友一直疑惑的符号<<-和符号<-的区别，也就在于此。

3.2.3　环境空间的访问

R语言提供了一些基础函数，可以帮助我们理解和使用环境空间。

·new.env创建一个环境空间。

·is.environment判断是否是环境空间类型。

·environment查看函数的环境空间定义。

·environmentName查看环境空间名字。

·env.profile查看环境空间属性值。

·ls查看环境空间中的对象。

·get取出指定环境空间中的对象。

·rm删除环境空间中的对象。

·assign给环境空间中的变量赋值。

·exists查看指定环境空间中的对象是否存在。

接下来，我们进行环境空间的访问操作。

> e1<-new.env（） # 新建一个环境空间
> is.environment（e1） # 判断e1是否是环境空间类型
[1] TRUE
> environment（） # 查看当前环境空间
<environment： R_GlobalEnv>
> environment（ls） # 查看函数的环境空间
<environment： namespace：base>
> environmentName（baseenv（）） # 查看环境空间的名字
[1] "base"
> environmentName（environment（））
[1] "R_GlobalEnv"
> environmentName（e1） # 查看e1环境空间的名字
[1] ""
> attr（e1，"name"）<-"e1" # 设置e1的名字
> environmentName（e1）
[1] "e1"
> env.profile（e1） # 查看e1环境空间的属性值
$size
[1] 29
$nchains
[1] 1
$counts
[1] 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

环境空间中的对象操作。

> rm（list=ls（）） # 清空当前环境空间定义的所有对象
> e1<-new.env（） # 定义环境空间和3个变量x
> x<-1：5；y<-2：10
> e1$x<-10
> ls（） # 查看当前环境中的变量
[1] "e1" "x" "y"
> ls（e1） # 查看e1环境空间中的变量
[1] "x"
> get（"x"） # 取当前环境空间的x值
[1] 1 2 3 4 5
> get（"x"，envir=e1） # 取e1环境空间的x值
[1] 10
# 在e1环境空间中取y值，这个y值是从当前环境空间中继承的
> get（"y"，envir=e1）
[1] 2 3 4 5 6 7 8 9 10
# 禁止环境空间的继承，在e1环境空间中取值，出错
> get（"y"，envir=e1，inherits=FALSE）
Error in get（"y"， envir = e1， inherits = FALSE） ： object 'y' not found
> assign（'x'，77）；x # 给x重新赋值
[1] 77
> assign（'x'，99，envir=e1）；e1$x # 给e1环境空间的x重新赋值
[1] 99
# 在没有继承的情况下，给e1空间增加y变量
> assign（'y'，99，envir=e1，inherits=FALSE）；
> y
[1] 2 3 4 5 6 7 8 9 10
> e1$y
[1] 99
# 删除e1环境空间的变量x和当前环境空间的y
> rm（x，envir=e1）
> e1$x
NULL
> x
[1] 77
# 查看当前环境空间和e1环境空间
> ls（）
[1] "e1" "x"
> ls（e1）
[1] "y"
# 查看x对象在当前环境空间是否存在
> exists（'x'）
[1] TRUE
# 查看x对象在e1环境空间是否存在
> exists（'x'，envir=e1）
[1] TRUE
# 查看x对象，在没有继承的情况下，在e1环境空间是否存在
> exists（'x'，envir=e1，inherits=FALSE）
[1] FALSE

另外，pryr包的where函数可以直接定位对象的环境空间。

# 查看mean函数定义的环境空间
> where（mean）
Error： is.character（name） is not TRUE
> 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"
# 查看x变量定义的环境空间
> where（"x"）
<environment： R_GlobalEnv>
# 查看y变量定义的环境空间，由于y变量定义在e1中，e1是当前空间的子空间，所以访问不到y变量
> where（"y"）
Error： Can't find y
> e1$y
[1] 99
# 在e1空间查看y变量
> where（"y"，e1）
<environment： 0x2545db0>

本节介绍了R语言中环境空间的定义、结构和一些简单应用，可以帮助大家更进一步地了解R语言的底层结构。环境空间的使用对于我们开发R包来说至关重要，一旦用好环境空间，那么你所开发的R包不仅能结构清晰而且会运行高效。

3.3　解密R语言函数的环境空间

问题

怎么应用R语言中的函数环境空间？

引言

本节接上一节继续介绍R语言中函数的环境空间。R语言的函数环境空间具有动态性，可以让我们用更少的代码构建出更复杂的应用。

3.3.1　R语言的函数环境空间

在R语言中，变量、对象、函数都存在于环境空间中，而函数又可以有自己的环境空间，我们可以在函数内再定义变量、对象和函数，循环往复就形成了我们现在用的R语言环境系统。

一般情况下，我们可以通过new.env（）去创建一个环境空间，但更多的时候，我们使用的是函数环境空间。函数环境空间，包括以下四方面的内容。

·封闭环境，每个函数都有且只有一个封闭环境空间，指向函数定义的环境空间。

·绑定环境，给函数指定一个名字，绑定到函数变量，如fun1<-function（）{1}。

·运行环境，当函数运行时，在内存中动态产生的环境空间，运行结束后，会自动销毁。

·调用环境，是指在哪个环境中进行的方法调用，如fun1<-function（）{fun2（）}，函数fun2在函数fun1中被调用。

本节的系统环境是：

·Windows 7 64bit

·R：3.1.1 x86_64-w64-mingw32/x64（64-bit）

3.3.2　封闭环境

封闭环境比较好理解，是对函数空间的一个静态定义，在函数定义时指向所在的环境空间，通过environment（）函数来查看封闭环境。我们在当前的环境空间定义一个函数f1，查看f1函数的封闭环境为R_GlobalEnv。

> y <- 1
> f1 <- function（x） x + y
> environment（f1）
<environment： R_GlobalEnv>

再定义一个函数f2，让f2函数调用f1函数，查看f2函数的封闭环境为R_GlobalEnv。

> f2 <- function（x）{
+ f1（）+y
+ }
> environment（f2）
<environment： R_GlobalEnv>

所以，封闭环境是在定义的时候设置的，与具体运行时环境没有关系。

3.3.3　绑定环境

绑定环境就是把函数的定义和调用通过函数变量连起来。比如，我们新建一个环境空间e，在e的环境空间中定义一个函数g，就相当于把一个函数绑定到g变量，通过找到e环境空间中的g变量，就可以调用这个函数。

> e <- new.env（） # 新建一个环境空间
> e$g <- function（） # 绑定一个函数到e$g
> e$g # 查看函数g的定义
function（） 1
> e$g（） # 运行函数g
[1] 1

在环境空间e中再定义一个嵌套函数e$f。

> e$f <- function（） { # 绑定一个函数到e$f
+ function （） 1
+ }
> e$f # 查看函数f的定义
function（） {
function （） 1
}
> e$f（） # 调用函数f，返回嵌套的匿名函数定义
function （） 1
<environment： 0x000000000dbc0a28>
> e$f（）（） # 调用函数f，和嵌套匿名函数，得到结果
[1] 1

查看函数g和f的封闭环境。

# 函数g和f的封闭环境
> environment（e$g）
<environment： R_GlobalEnv>
> environment（e$f）
<environment： R_GlobalEnv>
# f内部的匿名函数的封闭环境
> environment（e$f（））
<environment： 0x000000000d90b0b0>
# 匿名函数的父函数的封闭环境
> parent.env（environment（e$f（）））
<environment： R_GlobalEnv>

我们看到e$g和e$f两个函数定义的封闭环境，都是当前环境R_GlobalEnv。而e$f（）的匿名函数的封闭环境，是当前环境的子环境，也就是e$f函数的环境空间。

3.3.4　运行环境

运行环境是函数被调用时产生的内存环境。运行环境是临时的，当函数运行完成后，运行环境会被自动销毁。在运行环境中定义的变量、对象和函数，也是动态创建的，随着内存释放而销毁。

定义一个函数g，在函数g中，有临时变量a和参数x。

> g <- function（x） { # 定义函数g
+ if （！exists（"a"， inherits = FALSE）） {
+ a<-1
+ }
+ a<-a+x
+ a
+ }
> g（10） # 调用函数g
[1] 11
> g（10）
[1] 11

调用2次函数g，运行结果都是11。我们可以看出，变量a在g函数中为临时变量，没有进行持久化，每次调用函数g时，a都是新的值。增加一些输出信息，我们再来看看，这个函数的运行情况。

> g <- function（x） {
+ message（"Runtime function"） # 增加注释
+ print（environment（）） # 打印运行时环境
+ if （！exists（"a"， inherits = FALSE）） {
+ a<-1
+ }
+ a<-a+x
+ a
+ }
# 调用函数g
> g（10）
Runtime function
<environment： 0x000000000e447380>
[1] 11
> g（10）
Runtime function
<environment： 0x000000000d2fa218>
[1] 11

我们还是调用2次g函数，看到print（environment（））的输出，有2个不同的环境地址0x000000000e447380和0x000000000d2fa218。说明函数的运行时环境，是内存临时分配的。

3.3.5　调用环境

调用环境是指函数是在哪个环境中被调用的。匿名函数通常是在定义的封闭环境中被调用。下面我们定义一个嵌套的函数h，包括一个匿名函数。

> h <- function（） { # 函数h
+ x <- 5
+ function（） { # 匿名函数
+ x
+ }
+ }
> r1 <- h（） # 调用函数h，把h函数内部的匿名函数赋值给r1
> x <- 10 # 在当前环境定义变量x
> r1（） # 调用函数r1
[1] 5

r1（）函数运行后的结果为5，说明r1（）函数获得的是匿名函数所在的封闭环境的x值，而不是r1变量所在的当前环境的x值。我们把代码稍做修改，在函数h中，定义2个x变量。用<<-符号给第二个x变量赋值，相当于给父环境空间中的x变量赋值。

> h <- function（） {
+ x <- 10
+ x <<- 5
+ function（） {
+ x
+ }
+ }
> r1 <- h（） # 调用函数h
> r1（） # 调用函数r1（）
[1] 10
> x # 当前空间的变量x
[1] 5

r1（）函数运行后的结果为10，说明r1（）函数获得的是匿名函数所在的封闭环境的x值10，而不是通过<<-符号赋值的父环境中的x的值。

3.3.6　完整的环境操作

接下来，把函数环境空间的操作放到一起，做一个完整环境的说明，如图3-2所示。

图3-2　函数环境空间

图3-2的解释如下：

（1）小实心圆，表示函数封闭，始终指向函数定义的环境空间。

（2）左侧大长方形，表示已加载的包环境空间，包括R_GlobalEnv、base和R_EmptyEnv等。

（3）右侧大长方形，表示已定义的函数环境空间，包括environment：0x000000000e0db220和environment：0x000000000e0e8cf0。

（4）右侧大长方形内的小长方形，表示命名函数，包括fun1和fun2。

（5）左上不在大长方形内的小长方形，表示已定义的匿名函数，包括function。

（6）在大长方形内的小正方形，表示在环境空间中定义的变量，包括x、fx和f2。

（7）不在大长方形内的小正方形，表示在内存中的变量值，包括5、2、1。

（8）细实线，表示变量的赋值。

（9）细虚线，表示指向封闭环境空间。

（10）粗实线，表示函数调用过程。

（11）程序运行时，产生了函数环境空间的内存地址，包括0x000000000e0db220、0x000000000e0e8cf0和0x000000000e0db178。

图3-2中的结构，用R代码描述，如下所示。

> x<-5 # 在当前环境定义变量x
> fun1<-function（）{ # 在当前环境定义fun1
+ print（"fun1"） # 打印fun1环境空间
+ print（environment（））
+ x<-1 # 在fun1函数环境中，定义变量x
+ function（） {
+ print（"funX"） # 打印匿名环境空间
+ print（environment（））
+ x+15 # 从一级父环境空间中，找到变量x
+ }
+ }
> fun2<-function（）{ # 在当前环境定义fun2
+ print（"fun2"） # 打印fun2环境空间
+ print（environment（））
+ x<-2 # 在fun2函数环境中，定义变量x
+ fun1（） #调用函数fun1
+ }
> f2<-fun2（） # 在当前环境空间中，调用函数fun2，绑定到f2
[1] "fun2"
<environment： 0x000000000e0db220>
[1] "fun1"
<environment： 0x000000000e0e8cf0>
> fx<-f2（） # 在当前环境空间中，调用匿名函数，并绑定到fx
[1] "funX"
<environment： 0x000000000e0db178>
> fx # 输出fx的结果
[1] 16

最后，通过完整的例子，我们清楚了R语言环境空间的基本结构和调用关系。接下来，我们就可以利用环境空间的特性来做一些实际的开发任务了。

注　本节中对函数环境空间的定义，参考了Hadley Wickham的《Advanced R》。[1]

[1] 本书中文版也将由机械工业出版社华章分社出版。——编辑注

3.4　用R进行文件系统管理

问题

R怎么操作文件？

引言

R语言作为脚本语言，有一套文件系统管理的功能函数，也可以实现如Python一样的系统管理功能。本节将详细介绍R语言的文件系统管理。试试有什么不一样吧？

3.4.1　文件系统介绍

计算机的文件系统是一种存储和组织计算机数据的方法，它使得对其访问和查找变得容易，文件系统使用文件和树形目录的抽象逻辑概念代替了硬盘和光盘等物理设备使用数据块的概念，用户使用文件系统来保存数据，不必关心数据实际保存在硬盘（或者光盘）的地址为多少的数据块上，只需要记住这个文件的所属目录和文件名。在写入新数据之前，用户不必关心硬盘上的那个块地址有没有被使用，硬盘上的存储空间管理（分配和释放）功能由文件系统自动完成，用户只需要记住数据被写入到了哪个文件中。

R语言和其他编程语言一样，都有对文件系统的操作、包括文件操作和目录操作，函数API都定义在base包中。我们接下来就介绍用R进行文件系统管理。

3.4.2　目录操作

本节的系统环境是：

·Linux：Ubuntu Server 12.04.2 LTS 64bit

·R：3.1.1 x86_64-pc-linux-gnu（64-bit）

1.查看目录

随意进入一个目录，启动R程序，通过R语言函数查看当前目录下的子目录。

~ R # 启动R程序
> getwd（） # 当前的目录
[1] "/home/conan/R/fs"
> list.dirs（） # 查看当前目录的子目录
[1] "." "./tmp"

查看当前目录的子目录和文件。

> dir（） # 查看当前目录的子目录和文件
[1] "readme.txt" "tmp"
> dir（path="/home/conan/R"） # 查看指定目录的子目录和文件
[1] "A.txt" "caTools"
[3] "chinaWeather" "DemoRJava"
[5] "env" "FastRWeb"
[7] "font" "fs"
[9] "github" "lineprof"
[11] "pryr" "readme.txt"
[13] "RMySQL" "RServe"
[15] "rstudio-server-0.97.551-amd64.deb" "websockets"
[17] "x86_64-pc-linux-gnu-library"
> dir（path="/home/conan/R"，pattern='^R'） # 只列出以字母R开头的子目录或文件
[1] "RMySQL" "RServe"
> dir（path="/home/conan/R"，all.files=TRUE）
# 列出目录下所有的目录和文件，包括隐藏文件，如 .A.txt
[1] "." ".."
[3] ".A.txt" "A.txt"
[5] "caTools" "chinaWeather"
[7] "DemoRJava" "env"
[9] "FastRWeb" "font"
[11] "fs" "github"
[13] "lineprof" "pryr"
[15] "readme.txt" "RMySQL"
[17] "RServe" "rstudio-server-0.97.551-amd64.deb"
[19] "websockets" "x86_64-pc-linux-gnu-library"

还有另一种方式，查看当前目录的子目录和文件，同dir（）函数。

> list.files（）
[1] "readme.txt" "tmp"
> list.files（"."，all.files=TRUE）
[1] "." ".." "readme.txt" "tmp"

查看完整的目录信息。

# 查看当前目录权限
> file.info（"."）
size isdir mode mtime ctime atime uid gid uname grname
. 4096 TRUE 775 2013-11-14 08：40：46 2013-11-14 08：40：46 2013-11-14 08：41：57
1000 1000 conan conan
# 查看指定目录权限
> file.info（"./tmp"）
size isdir mode mtime ctime atime uid gid uname grname
./tmp 4096 TRUE 775 2013-11-14 14：35：56 2013-11-14 14：35：56 2013-11-14 14：35：56
1000 1000 conan conan

2.创建目录

如果我们要在当前目录下，新建一个目录，可以用下面的代码。

> dir.create（"create"） # 在当前目录下，新建一个目录
> list.dirs（） # 查看当前目录的子目录
[1] "." "./create" "./tmp"

创建一个3级子目录./a1/b2/c3。

> dir.create（path="a1/b2/c3"） # 直接创建，出错
Warning message：
In dir.create（path = "a1/b2/c3"） ：
cannot create dir 'a1/b2/c3'， reason 'No such file or directory'
> dir.create（path="a1/b2/c3"，recursive = TRUE） # 递归创建，成功
> list.dirs（）
[1] "." "./a1" "./a1/b2" "./a1/b2/c3" "./create" "./tmp"

在R语言中，也可以直接调用系统命令，查看目录结构。

> system（"tree"） # 通过系统命令查看目录结构
.├── a1│ └── b2│ └── c3├── create├── readme.txt└── tmp

3.检查目录是否存在

我们可以通过file.exists（）函数检查目录是否存在。

> file.exists（"."） # 目录存在
[1] TRUE
> file.exists（"./a1/b2"）
[1] TRUE
> file.exists（"./aa"） # 目录不存在
[1] FALSE

4.检查目录的权限

对于Linux系统，每个目录和文件都是权限定义。我们可以检查目录的权限。

> df<-dir（full.names = TRUE）
> file.access（df， 0） == 0 # 检查文件或目录是否存在，mode=0
./a1 ./create ./readme.txt ./tmp
TRUE TRUE TRUE TRUE
> file.access（df， 1） == 0 # 检查文件或目录是否可执行，mode=1，目录为可以执行
./a1 ./create ./readme.txt ./tmp
TRUE TRUE FALSE TRUE
> file.access（df， 2） == 0 # 检查文件或目录是否可写，mode=2
./a1 ./create ./readme.txt ./tmp
TRUE TRUE TRUE TRUE
> file.access（df， 4） == 0 # 检查文件或目录是否可读，mode=4
./a1 ./create ./readme.txt ./tmp
TRUE TRUE TRUE TRUE

我们还可以修改目录的权限。

> Sys.chmod（"./create"， mode = "0555"， use_umask = TRUE） # 修改目录权限，所有用户只读
> file.info（"./create"） # 查看目录完整信息，mode=555
size isdir mode mtime ctime atime uid gid uname grname
./create 4096 TRUE 555 2013-11-14 08：36：28 2013-11-14 09：07：05 2013-11-14 08：36：39
1000 1000 conan conan
> file.access（df， 2） == 0 # create目录不可以写
./a1 ./create ./readme.txt ./tmp
TRUE FALSE TRUE TRUE

5.对目录重命名

我们可以通过file.rename（）函数对目录进行重命名。

> file.rename（"tmp"， "tmp2"） # 对tmp目录重命名
[1] TRUE
# 查看目录
> dir（）
[1] "a1" "create" "readme.txt" "tmp2"

6.删除目录

我们可以通过unlink（）函数删除一个目录，如果目录中包括子目录或文件，需要递归删除。

> unlink（"tmp2"， recursive = TRUE） # 删除tmp2目录
> dir（） # 查看目录
[1] "a1" "create" "readme.txt"

7.其他功能函数

除了一些基础的目录操作外，R语言还提供了一些辅助功能函数，比如拼接目录字符串，获取最底层的子目录名，转换文件扩展路径，标准化路径转换Windows或linux的路径分隔符、短路径等。

拼接目录字符串。

> file.path（"p1"，"p2"，"p3"） # 拼接目录字符串
[1] "p1/p2/p3"
> dir（file.path（"a1"，"b2"））
[1] "c3"

获取最底层的子目录名。

> getwd（） # 当前目录
[1] "/home/conan/R/fs"
> dirname（"/home/conan/R/fs/readme.txt"） # 完整的目录路径
[1] "/home/conan/R/fs"
> basename（getwd（）） # 最底层的目录名
[1] "fs"
> basename（"/home/conan/R/fs/readme.txt"） #最底层的文件名
[1] "readme.txt"

转换文件扩展路径。

> path.expand（"~/foo"） # 转换~为用户目录
[1] "/home/conan/foo"

标准化路径，用来转换Windows或linux的路径分隔符。

> normalizePath（c（R.home（）， tempdir（））） # Linux系统
[1] "/usr/lib/R" "/tmp/RtmpqNyjPD"
> normalizePath（c（R.home（）， tempdir（））） # Windows系统
[1] "C：\\Program Files\\R\\R-3.0.1"
[2] "C：\\Users\\Administrator\\AppData\\Local\\Temp\\RtmpMtSnci"

短路径，缩减路径的显示长度，只在Windows中运行。

> shortPathName（c（R.home（）， tempdir（））） # Windows系统
[1] "C：\\PROGRA~1\\R\\R-30~1.1"
[2] "C：\\Users\\ADMINI~1\\AppData\\Local\\Temp\\RTMPMT~1"

3.4.3　文件操作

R语言不仅可以对目录操作，还可以对文件进行操作，有丰富的API支持。

1.查看文件

我们可以通过dir（）函数查看当前目录的文件。

> dir（） # 查看当前目录的文件
[1] "create" "readme.txt"
> file.exists（"readme.txt"） # 检查文件是否存在
[1] TRUE
> file.exists（"readme.txt222"） # 文件不存在
[1] FALSE
> file.info（"readme.txt"） # 查看文件完整信息
size isdir mode mtime ctime atime uid gid uname grname
readme.txt 7 FALSE 664 2013-11-14 08：24：50 2013-11-14 08：24：50 2013-11-14 08：24：50
1000 1000 conan conan
> file.access（"readme.txt"，0） # 查看文件访问权限，存在
readme.txt
0
> file.access（"readme.txt"，1） # 文件权限，不可执行
readme.txt
-1
> file.access（"readme.txt"，2） # 文件权限，可写
readme.txt
0
> file.access（"readme.txt"，4） # 文件权限，可读
readme.txt
0
> file.access（"readme.txt222"） # 查看一个不存在的文件访问权限，不存在
readme.txt222
-1

判断是文件还是目录。

> file_test（"-d"， "readme.txt"） # 判断是否是目录
[1] FALSE
> file_test（"-d"， "create"）
[1] TRUE
> file_test（"-f"， "readme.txt"） # 判断是否是文件
[1] TRUE
> file_test（"-f"， "create"）
[1] FALSE

2.创建文件

我们可以通过file.create（）函数创建一个文件。

> file.create（"A.txt"） # 创建一个空文件 A.txt
[1] TRUE
> cat（"file B\n"， file = "B.txt"） # 创建一个有内容的文件 B.txt
> dir（）
[1] "A.txt" "B.txt" "create" "readme.txt"
> readLines（"A.txt"） # 打印A.txt
character（0）
> readLines（"B.txt"） # 打印B.txt
[1] "file B"

把文件B.txt的内容，合并到A.txt。

> file.append（"A.txt"， rep（"B.txt"， 10）） # 合并文件
[1] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
> readLines（"A.txt"） # 查看文件内容
[1] "file B" "file B" "file B" "file B" "file B" "file B" "file B" "file B" "file B"
"file B"

把文件A.txt复制到文件C.txt

> file.copy（"A.txt"， "C.txt"） # 复制文件
[1] TRUE
> readLines（"C.txt"） # 查看文件内容
[1] "file B" "file B" "file B" "file B" "file B" "file B" "file B" "file B" "file B"
"file B"

3.修改文件权限

我们可以通过Sys.chmod（）函数修改文件权限。

# 修改文件权限，创建者可读可写可执行，其他人无权限
> Sys.chmod（"A.txt"， mode = "0700"， use_umask = TRUE）
> file.info（"A.txt"） # 查看文件信息
size isdir mode mtime ctime atime uid
gid uname grname
A.txt 70 FALSE 700 2013-11-14 12：55：18 2013-11-14 12：57：39 2013-11-14 12：55：26
1000 1000 conan conan

4.文件重命名

我们可以通过file.rename（）函数对文件重命名。

> file.rename（"A.txt"，"AA.txt"） # 给文件A.txt重命名为AA.txt
[1] TRUE
> dir（）
[1] "AA.txt" "B.txt" "create" "C.txt" "readme.txt"

5.硬连接和软连接

硬连接，指通过索引节点来进行连接。在Linux的文件系统中，保存在磁盘分区中的文件不管是什么类型都会被分配一个编号，称为索引节点号。在Linux中，多个文件名指向同一索引节点是存在的。一般这种连接就是硬连接。硬连接的作用是允许一个文件拥有多个有效路径名，这样用户就可以建立硬连接到重要文件，以防止“误删”的功能。其原因如上所述，因为与该目录对应的索引节点有一个以上的连接。只删除一个连接并不影响索引节点本身和其他的连接，只有当最后一个连接被删除后，文件的数据块及目录的连接才会被释放。也就是说，文件真正删除的条件是与之相关的所有硬连接文件均被删除。

软连接，也叫符号连接。软链接文件有类似于Windows的快捷方式。它实际上是一个特殊的文件。在符号连接中，文件实际上是一个文本文件，其中包含的有另一文件的位置信息。

注　硬连接和软连接，只在Linux系统中使用。

> file.link（"readme.txt"， "hard_link.txt"） # 硬连接
[1] TRUE
> file.symlink（"readme.txt"， "soft_link.txt"） # 软连接
[1] TRUE
> system（"ls -l"） # 查看文件目录
-rwx------ 1 conan conan 70 Nov 14 12：55 AA.txt
-rw-rw-r-- 1 conan conan 7 Nov 14 12：51 B.txt
dr-xr-xr-x 2 conan conan 4096 Nov 14 08：36 create
-rw-rw-r-- 1 conan conan 70 Nov 14 12：56 C.txt
-rw-rw-r-- 2 conan conan 7 Nov 14 08：24 hard_link.txt
-rw-rw-r-- 2 conan conan 7 Nov 14 08：24 readme.txt
lrwxrwxrwx 1 conan conan 10 Nov 14 13：11 soft_link.txt -> readme.txt

文件hard_link.txt是文件readme.txt硬连接文件，文件soft_link.txt是文件readme.txt软连接文件。

6.删除文件

删除文件有两个函数可以使用，即file.remove（）和unlink（），其中unlink函数使用同删除目录操作是一样的。

> file.remove（"A.txt"， "B.txt"， "C.txt"） # 删除文件
[1] FALSE TRUE TRUE
> unlink（"readme.txt"） # 删除文件
> system（"ls -l"） # 查看目录文件
total 12
-rwx------ 1 conan conan 70 Nov 14 12：55 AA.txt
dr-xr-xr-x 2 conan conan 4096 Nov 14 08：36 create
-rw-rw-r-- 1 conan conan 7 Nov 14 08：24 hard_link.txt
lrwxrwxrwx 1 conan conan 10 Nov 14 13：11 soft_link.txt -> readme.txt
> readLines（"hard_link.txt"） # 打印硬连接文件
[1] "file A"
# 打印软连接文件，soft_link.txt，由于原文件被删除，有错误
> readLines（"soft_link.txt"）
Error in file（con， "r"） ： cannot open the connection
In addition： Warning message：
In file（con， "r"） ：
cannot open file 'soft_link.txt'： No such file or directory

3.4.4　几个特殊的目录

·R.home（）查看R软件的相关目录

·.Library查看R核心包的目录

·.Library.site查看R核心包的目录和root用户安装包目录

·.libPaths（）查看R所有包的存放目录

·system.file（）查看指定包所在的目录

1.R.home（）查看R软件的相关目录

> R.home（） # 打印R软件安装目录
[1] "/usr/lib/R"
> R.home（component="bin"） # 打印R软件bin的目录
[1] "/usr/lib/R/bin"
> R.home（component="doc"） # 打印R软件bin的目录
[1] "/usr/share/R/doc"

通过系统命令，找到R文件的位置。

~ whereis R # 检查系统中R文件的位置
R： /usr/bin/R /etc/R /usr/lib/R /usr/bin/X11/R /usr/local/lib/R /usr/share/R /
usr/share/man/man1/R.1.gz
~ echo $R_HOME # 打印环境变量R_HOME
/usr/lib/R

通过R.home（）函数，我们可以很容易地定位R软件的目录。

2.R软件的包目录

> .Library # 打印核心包的目录
[1] "/usr/lib/R/library"
> .Library.site # 打印核心包的目录和root用户安装包目录
[1] "/usr/local/lib/R/site-library" "/usr/lib/R/site-library"
[3] "/usr/lib/R/library"
> .libPaths（） # 打印所有包的存放目录
[1] "/home/conan/R/x86_64-pc-linux-gnu-library/3.0"
[2] "/usr/local/lib/R/site-library"
[3] "/usr/lib/R/site-library"
[4] "/usr/lib/R/library"

3.查看指定包所在的目录

> system.file（） # base包的存放目录
[1] "/usr/lib/R/library/base"
> system.file（package = "pryr"） # pryr包的存放目录
[1] "/home/conan/R/x86_64-pc-linux-gnu-library/3.0/pryr"

其实，用R语言操作文件系统还是很方便的。但对于函数命名确实不太规范，需要我们花时间记忆。

3.5　R语言3.1.x版本新特性

问题

如何掌握R语言的新特性？

引言

R语言在不断地发展和进步，从3.0.0版本开始，R语言开始了具有里程碑式的发展，并且持续壮大和发展。R内核在不断更新，越来越多的纯计算机技术指标在增加，向着企业级商用语言在靠近。本节将介绍R的最新版本3.1.x的新特性及使用。

3.5.1　R语言3.1.x版本介绍

R语言3.1.0版本于2014年4月10日发布，发布了64项新特性，修复了16个bug，是一次很大规模的升级。目前的最新版本的R语言3.1.1版本发布于2014年7月10日，有17项新特性发布，并解决了35个bug。

一般软件产品版本发布，都用3个维度来衡量，即X.Y.Z，按照从左到右的顺序以点分隔，如R语言的3.1.1版本。

·X代表最大的版本号，表示有重大的更新或者里程碑的功能点发布，大版本号新产品发布建议大家升级，使用最新的软件，比如Java5、Java6、Java7、Java8每次升级都对Java性能及特性有重大的提升及改进。当然，大版本的升级，也可能会向前不兼容，以致很多原来开发的应用都不能运行了，如Python 2.7.x和Python 3.x就是语法不兼容的，现在只能两套版本并行。

·Y代表中版本号，主要表现在功能上，每一次Y的版本升级，都会对当前版本补充很多小功能，这些小功能一般是不太会引起大家的注意，也不会影响使用，可以想起来再升级，差一两个Y的版本没什么关系。

·Z代表小版本号，主要表现在解决bug上，每个X和Y版本的升级都可能会引起bug，这些bug需要及时修复，所以Z的版本会经常性地发布，有时候是一两个月也可能三五天。我们可以把Z的版本号，理解为给系统打补丁，只有你遇到这个bug才需要打补丁，如果没有遇到bug，对于Z的版本，我们可以不升级，等下个Y版本发布再统一升级。

R语言的快速更新，其实代表了市场迫切的声音。如果R语言能支持并发，如果R语言能支持异步，如果R语言能构建独立的应用服务器，如果R语言能方便地处理socket和http协议，如果R语言能处理大数据……已经有无数的功能需求被提交到了R的核心团队。我也希望R的技术小组能早日攻克这些技术难题，让R在企业级的应用中大放异彩。

从R语言版本平均每4个月新发布一次，就能看出大家都在努力着。我们可通过官方的软件镜像下载R语言最新版本软件包（http://cran.rstudio.com/），并查看版本更新的详细描述，如图3-3所示。

图3-3　R软件新版本发布页

本节的系统环境是：

·Windows 7 64bit

·R：3.1.1 x86_64-w64-mingw32/x64（64-bit）

下面我就全面解释R语言3.1.0和3.1.1两个版本的新特性，并做代码的描述。

3.5.2　R语言3.1.0新特性及代码描述

R语言3.1.0版本的别名是Spring Dance，下载R3.1.0版本后，你可以通过version来查看版本信息。

~ R # 启动R程序
> version # 查看版本信息
platform x86_64-w64-mingw32
arch x86_64
os mingw32
system x86_64， mingw32
status
major 3
minor 1.0
year 2014
month 04
day 10
svn rev 65387
language R
version.string R version 3.1.0 （2014-04-10）
nickname Spring Dance

R3.1.0有以下64个新特性。

（1）type.convert（）函数主要用在read.table（）函数中，返回向量和因子类型，当输入为double型时会丢失精度。

> type.convert（c（'abc'，'bcd'）） # 返回因子类型
[1] abc bcd
Levels： abc bcd
> type.convert（c（as.double（1.12121221111），'1.121'）） # double型丢失精度
[1] 1.121212 1.121000

（2）如果一个文件包含有小数位的数据，通过read.table（）函数读取时，会指定为numeric类型。

新建一个文件num.csv包括小数。

1，2，1.11
2.1，3，4.5

用read.table读取文件，并查看列的类型。

> num<-read.table（file="num.csv"，sep="，"） # 读文件
> num
V1 V2 V3
1 1.0 2 1.11
2 2.1 3 4.50
> class（num）
[1] "data.frame"
> class（num$V1） # 查看列的类型为numeric
[1] "numeric"

（3）tools包用Rdiff（）函数的参数useDiff为FALSE时，与POSIX系统的diff-b命令类似。

新建文件num2.csv。

3，2，1.11
2.1，3，4.5

用Rdiff（）比较两个文件num.csv和num2.csv。

> Rdiff（'num.csv'，'num2.csv'，useDiff = FALSE）
< 1，2，1.11
---
> 3，2，1.11
[1] 1

（4）新函数anyNA（），结果与any（is.na（.））一致，性能更好。

> is.na（c（1， NA））
[1] FALSE TRUE
> any（is.na（c（1， NA）））
[1] TRUE
> anyNA（c（1， NA））
[1] TRUE

（5）arrayInd（）和which（）函数增加useNames参数，用于列名的匹配。我在测试过程，不太理解这个参数的意义。

> which
function （x， arr.ind = FALSE， useNames = TRUE）

（6）is.unsorted（）函数支持处理原始数据的向量。

> is.unsorted（1：10） # 排序的向量
[1] FALSE
> is.unsorted（sample（1：10）） # 无序的向量
[1] TRUE

（7）用于处理table的as.data.frame（）函数和as.data.frame.table（）函数，支持向provideDimnames（sep，base）函数传参数。我在测试过程中，也不理解具体是什么更新。

（8）uniroot（）函数增加新的可选参数extendInt，允许自动扩展取值范围，并增加返回对象参数init.it。

> f1 <- function（x） （121 - x^2）/（x^2+1） # 函数f1
> f2 <- function（x） exp（-x）*（x - 12） # 函数f2
> try（uniroot（f1， c（0，10））） # 在（0，10）的区间求f1函数的根
Error in uniroot（f1， c（0， 10）） ：
f（） values at end points not of opposite sign
> try（uniroot（f2， c（0， 2））） # 在（0，2）的区间求f2函数的根
Error in uniroot（f2， c（0， 2）） ：
f（） values at end points not of opposite sign
> str（uniroot（f1， c（0，10），extendInt="yes"）） # 通过extendInt参数扩大取值搜索范围
List of 5
$ root ： num 11
$ f.root ： num -3.63e-06
$ iter ： int 12
$ init.it ： int 4
$ estim.prec： num 6.1e-05
> str（uniroot（f2， c（0，2）， extendInt="yes"）） # 通过extendInt参数扩大取值搜索范围
List of 5
$ root ： num 12
$ f.root ： num 4.18e-11
$ iter ： int 23
$ init.it ： int 9
$ estim.prec： num 6.1e-05

（9）switch（f，）函数，当参数f是因子类型时，会给出警告提示，需要转换字符串参数。

> ff<-gl（3，1， labels=LETTERS[3：1]）
> switch（ff[1]， A = "I am A"， B="Bb.."， C=" is C"）# -> "A" # 警告提示
[1] "I am A"
Warning message：
In switch（ff[1]， A = "I am A"， B = "Bb.."， C = " is C"） ：
EXPR is a "factor"， treated as integer.
Consider using 'switch（as.character（ * ）， ...）' instead.
> switch（as.character（ff[1]）， A = "I am A"， B="Bb.."， C=" is C"） # 转型为字符串处理
[1] " is C"

（10）解析器已经更新，使用更少的内存。

（11）一元运算符“+-！”对属性值操作时，会做一份拷贝计算，但names，dims和dimnames是例外的。

> x<-1：12；x # 创建变量x
[1] 1 2 3 4 5 6 7 8 9 10 11 12
> x+5 # 拷贝计算，不影响原变量x的值
[1] 6 7 8 9 10 11 12 13 14 15 16 17
> ！x
[1] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE
> dim（x） <- c（3，4）；x # 直接修改原变量x的值
[，1] [，2] [，3] [，4]
[1，] 1 4 7 10
[2，] 2 5 8 11
[3，] 3 6 9 12

（12）colorRamp（）和colorRampPalette（）支持透明色，让alpha参数为TRUE。

> cols<-colorRampPalette（c（rgb（0，0，1，1）， rgb（1，0，1，0））， alpha = TRUE） # 取色的函数句柄
> filled.contour（volcano，color.palette =cols，asp = 1） # 画图，带透明色火山图片，如图3-4所示。

图3-4　带透明色火山图

（13）grid.show.layout（）函数和grid.show.viewport（）函数，都增加一个可选的参数vp.ex，用于布局缩放。

> library（grid） # 加载gird包
> grid.show.layout # 查看函数定义
function （l， newpage = TRUE， vp.ex = 0.8， bg = "light grey"，
cell.border = "blue"， cell.fill = "light blue"， cell.label = TRUE，
label.col = "blue"， unit.col = "red"， vp = NULL）

（14）新的函数find_gs_cmd（）在tools包中，用来定位GhostScript的可执行文件。

（15）object.size（）函数增加format（）方法定义，用于格式显示。

> letters
[1] "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" "p" "q" "r" "s" "t"
[21] "u" "v" "w" "x" "y" "z"
> object.size（letters） # 查看letters对象大小
1496 bytes
> format（object.size（letters）， units = "auto"） # 格式化显示
[1] "1.5 Kb"

（16）增加新字体ArialMT，用于pdf（）和postscript（）设备输出。

（17）R软件的NEWS和NEWS.2文件，及新生成的文本和PDF文件，被移到doc目录存储。

> dir（"C：/Program Files/R/R-3.1.0/doc"） # 查看doc目录，包括NEWS和NEWS.2文件
[1] "AUTHORS" "CHANGES" "CHANGES.rds" "COPYING"
[5] "COPYRIGHTS" "CRAN_mirrors.csv" "FAQ" "html"
[9] "KEYWORDS" "KEYWORDS.db" "manual" "NEWS"
[13] "NEWS.0" "NEWS.1" "NEWS.2" "NEWS.pdf"
[17] "NEWS.rds" "README.packages" "README.Rterm" "RESOURCES"
[21] "rw-FAQ" "THANKS"

（18）combn（x）函数支持参数x为因子类型，并返回因子类型。

> combn（letters[1：4]， 2） # 字符串类型
[，1] [，2] [，3] [，4] [，5] [，6]
[1，] "a" "a" "a" "b" "b" "c"
[2，] "b" "c" "d" "c" "d" "d"
> combn（factor（letters[1：4]）， 2） # 因子类型
[，1] [，2] [，3] [，4] [，5] [，6]
[1，] a a a b b c
[2，] b c d c d d
Levels： a b c d

（19）在utils包增加fileSnapshot（）函数和changedFiles（）函数，用于产生目录的文件快照和比较目录的快照文件。

> snapshot<-fileSnapshot（） # 产生快照
> snapshot
File snapshot：
path = D：\workspace\R\basic\r311
timestamp =
file.info = TRUE
md5sum = FALSE
digest = NULL
full.names = FALSE
args = list（）
9 files recorded.
> writeBin（3L：4L，"a.txt"） # 在当目录中增加一个文件a.txt
> changedFiles（snapshot） # 比较目录快照
Files added：
a.txt

（20）make.names（）可以处理不合法的变量命名，当unique参数为TRUE时，新生成的变量名不重复。

> make.names（c（"a b"，"a.b"， "a-b"）） # 处理不正确的变量名
[1] "a.b" "a.b" "a.b"
> make.names（c（"a b"，"a.b"， "a-b"）， unique = TRUE） # 会生成3个不同的变量名
[1] "a.b.1" "a.b" "a.b.2"

（21）增加新函数cospi（x）、sinpi（x）和tanpi（x），用于精确计算cos（pi*x），被lgamma（）和besselI（）等函数底层调用。

> x<-1222222222222221.323232
> cospi（x） # 当x变量值过大时，解决cos（pi*x）计算误差的问题
[1] -0.7071068
> cos（pi*x）
[1] -0.7175645

（22）print.table（x）函数，支持x为小数。

> t1 <- round（abs（rt（10， df = 1.8）），1）
> t2 <- round（abs（rt（10， df = 1.4）），1）
> print.table（table（t1，t2），zero.print = "."）
t2
t1 0 0.1 0.4 0.5 1 1.2 1.3 1.7 8.2
0.1 . . . . . . . . 1
0.2 . . 1 . . . 1 . .
0.4 . . . . 1 . . . .
0.7 . 1 . . . . . . .
0.8 1 . . . . . . . .
1.2 . . . 1 . 1 . . .
1.4 . . 1 . . . . . .
2.2 . . . . . . . 1 .

（23）支持更多的时间，通过OlsonNames（）函数查看时区列表，用Sys.timezone（）函数查看当前系统环境绑定的时区。

> head（OlsonNames（）） # 时区列表
[1] "Africa/Abidjan" "Africa/Accra"
[3] "Africa/Addis_Ababa" "Africa/Algiers"
[5] "Africa/Asmara" "Africa/Asmera"
> Sys.timezone（） # 我的系统绑定的时区
[1] "Asia/Taipei"

（24）系统支持64位的time_t类型，从而可以方便地处理超出32位的时间部分，如1902年以前，和2038以后的时间，目前还不支持OS X系统。

（25）目前time_t类型被用于部分的类Unit的64位系统上和Windows的64位系统上。

（26）增加新的环境设置，save.defaults选项包括compression_level的配置。

（27）colSums（）函数，支持数组和数据框在2^31个元素以上的计算。

（28）优化as.factor（）函数性能，加速非integer类型的向量转换。

> a<-rnorm（1000000，-100，100000）
> head（a）
[1] 9856.935 154567.963 -200041.134 43363.338 -74436.650
[6] -178322.313
> system.time（as.factor（a））用户 系统 流逝
9.50 0.03 9.64

（29）快速傅立叶变换fft（）函数支持大数据量计算，从原来的1200万个增加到2亿个。

> x <- 1：100000000 # 对1亿个数字进行傅立叶变换
> system.time（fft（x））
用户 系统 流逝
32.96 0.22 33.32

（30）svd（）函数用LAPACK软件的子程序ZGESDD实现，在真实的环境下进行复杂的模拟计算。

（31）如果让Sweave输出的.tex文件为UTF-8编码，你需要在LaTex文件中增加%\SweaveUTF8的设置。

（32）文件操作file.copy（）函数，增加copy.date（）的参数，让复制的文件与原文件有相同的修改时间。

> file.copy（"a.txt"，"b.txt"，copy.date=TRUE） # 创建文件b.txt
[1] TRUE
> file.copy（"a.txt"，"c.txt"，copy.date=FALSE） # 创建文件c.txt
[1] TRUE

a.txt和b.txt有相同的文件修改时间，c.txt是全新创建的，如图3-5所示。

（33）用缩写字母表示时区中的时间日期，在POSIXlt类中设置可选的参数zone，如巴黎1940年之前，缩写为LMT，PMT WET或WEST。

（34）gmtoff组件可以用于记录GMT的偏移量，在支持的平台上。

（35）C语言实现的strftime（）函数被更新到POSIX 2008标准，用于Windows和OS X等系统。

（36）dnorm（x）函数计算结果更准确，但当|x|>5的时候，性能下降。

> dnorm（rnorm（10，0，100）） # 执行dnorm（）函数
[1] 1.151100e-271 0.000000e+00 2.403071e-198 0.000000e+00
[5] 0.000000e+00 3.358647e-208 0.000000e+00 0.000000e+00
[9] 0.000000e+00 1.136764e-154

图3-5　比较3个文件的属性信息

（37）tiff（）函数增加压缩选项compression参数。

> tiff
function （filename = "Rplot%03d.tif"， width = 480， height = 480， units = "px"，
pointsize= 12， compression = c（"none"， "rle"，"lzw"， "jpeg"， "zip"， "lzw+p"，
"zip+p"）， bg = "white"， res = NA， family = "sans"， restoreConsole = TRUE，
type = c（"windows"，"cairo"）， antialias = c（"default"， "none"， "cleartype"，
"grey"， "subpixel"））

（38）read.table（），readLines（）和scan（）函数，读取数据时增加新参数skipNul，用于跳过空值。

> readLines
function （con = stdin（）， n = -1L， ok = TRUE， warn = TRUE， encoding = "unknown"，
skipNul = FALSE）

（39）赋值时，避免右侧重复值的复杂计算，将减少替换值的拷贝。

（40）同时，一些其他的变化，也将减少对象的拷贝。

（41）KalmanLike（），KalmanRun（）和KalmanForecast（）函数的fast参数被mod参数替换，用于返回更新后的模型。

> fit3 <- arima（presidents， c（3， 0， 0））
> mod <- fit3$model # 模型
> pr <- KalmanForecast（4， mod， TRUE） # 执行卡尔曼预测函数
> mod <- attr（pr， "mod"） # 更新后的模型，保存在mod属性中

（42）arima（）和makeARIMA（）增加新的参数SSinit，计算状态空间的初始化的似然函数。

> arima
function （x， order = c（0L， 0L， 0L）， seasonal = list（order = c（0L， 0L， 0L）， period
= NA）， xreg = NULL， include.mean = TRUE， transform.pars = TRUE， fixed = NULL，
init = NULL， method = c（"CSS-ML"， "ML"， "CSS"）， n.cond， SSinit =
c（"Gardner1980"， "Rossignol2011"）， optim.method = "BFGS"， optim.control = list（），
kappa = 1e+06）

（43）warning（）函数增加新的参数noBreaks，用于简化输出处理。

> warning
function （...， call. = TRUE， immediate. = FALSE， noBreaks. = FALSE， domain = NULL）

（44）pushBack（）函数增加新的参数encoding，支持scan（），read.table（）等函数读取UTF-8编码的文件。

> pushBack # 检查pushBack函数定义
function （data， connection， newLine = TRUE， encoding = c（""， "bytes"， "UTF-8"））
> zz <- textConnection（LETTERS） # 建个文本通道
> readLines（zz， 2）
[1] "A" "B"
> pushBack（c（"aa"， "bb"）， zz） # 把aa，bb写入在zz对象中
> pushBackLength（zz）
[1] 2
> readLines（zz， 1）
[1] "aa"
> pushBackLength（zz）
[1] 1
> readLines（zz， 1）
[1] "bb"
> readLines（zz， 1）
[1] "C"
> close（zz）

（45）all.equal.list（）函数增加新参数use.names，通过名字取代索引值来判断对象是否相等。

> a<-list（a=1，b=2）
> b<-list（）
> b[['a']]<-1
> b[['b']]<-2
> all.equal.list（a，b） # 相等
[1] TRUE
> b[['a']]<-4
> all.equal.list（a，b， use.names=TRUE） # 不相等
[1] "Component "a"： Mean relative difference： 3"

（46）all.equal（）和attr.all.equal（）增加新参数check.attributes，用于比较列名。

（47）all.equal（）函数增加了检查，解决了之前未检查的空参数引入的错误。

（48）把check.attributes参数用于显示检查，允许NULL和numeric类型，会发现意想不到的错误。

（49）all.equal.numeric（）函数，当遇到比较的对象长度不一致时，会出现“规模差异”的提示，但不是错误。

> all.equal.numeric（1：10，1：5）
[1] "Numeric： lengths （10， 5） differ"

（50）all.equal（）函数用POSIXt方法代替POSIXct方法。

（51）用seq（）函数生成Date和POSIXt类型的序列时，允许使用by=quarter的分隔法。

> seq（today，today+365，by="quarter"） # 按季度
[1] "2014-09-26" "2014-12-26" "2015-03-26" "2015-06-26" "2015-09-26"
> seq（today，today+365，by="2 months"） # 按2个月
[1] "2014-09-26" "2014-11-26" "2015-01-26" "2015-03-26" "2015-05-26"
[6] "2015-07-26" "2015-09-26"

（52）file.path（）函数用于适配路径分隔符，这个函数在我测试过程中完全没有作用。

> file.path（c（"c：//abc\\000\\llj/jkh"，"c：/abc/a"，"d：\\bcd"）） # 没有转换路径
[1] "c：//abc\\000\\llj/jkh" "c：/abc/a"
[3] "d：\\bcd"

（53）增加新函数agrepl（），用于模糊匹配。

> agrepl（"laysy"， c（"1 lazy"， "1"， "1 LAZY"）， max = 2）
[1] TRUE FALSE FALSE

（54）让fifo（）函数支持Windows系统。

> capabilities（"fifo"） # 检查系统是否支持

（55）sort.list（method="radix"）函数，支持基数排序，用于数据量很大但值域个数很少的情况，比普通排序快很多。

> x<-sample（1：650，1e7，replace=TRUE）
> system.time（o1<-sort.list（x）） # 普通排序用户 系统 流逝
7.13 0.02 7.14
> system.time（o2<-sort.list（x，method="radix"）） # 基数排序用户 系统 流逝
0.08 0.00 0.07
> all.equal（o1，o2） # 计算结果是一致的
[1] TRUE

（56）print.ts（）方法增加.preformat.ts（）函数。

> x<-sample（1：650，1e7，replace=TRUE）
> system.time（o1<-sort.list（x）） # 普通排序用户 系统 流逝
7.13 0.02 7.14
> system.time（o2<-sort.list（x，method="radix"）） # 基数排序用户 系统 流逝
0.08 0.00 0.07
> all.equal（o1，o2） # 计算结果是一致的
[1] TRUE

（57）mcparallel（）函数增加一个参数detach，可以执行代码独立于当前的会话。它底层调用mcfork（）函数设置参数estranged=TRUE，从而启动一个子进程独立于父进程运行。

（58）pdf（）函数输出时，将省略非常小的尺寸圆和文字，很多用户没有这样的文件。

（59）hist.POSIXlt（）函数在用months，quarters和years分隔时，右边将多加一天。

（60）data.frame类型，支持索引为0，不报错。

> df<-data.frame（1：5）
> df[0，]
integer（0）
> df[1，]
[1] 1

（61）hclust（）函数增加ward.D2的算法实现，之前的ward算法改名为ward.D。

> m<-matrix（sample（100，100，replace=TRUE），10）；m
[，1] [，2] [，3] [，4] [，5] [，6] [，7] [，8] [，9] [，10]
[1，] 8 21 93 10 4 40 61 26 55 22
[2，] 100 85 24 98 94 1 75 70 34 85
[3，] 12 59 12 13 28 72 76 81 94 12
[4，] 97 34 21 50 98 26 14 37 72 62
[5，] 27 98 14 22 16 90 57 36 60 29
[6，] 24 87 22 6 61 68 17 13 27 93
[7，] 94 87 64 5 89 81 27 1 18 61
[8，] 98 89 5 5 40 26 45 4 36 53
[9，] 34 10 32 31 100 31 64 20 25 85
[10，] 19 38 71 72 35 40 75 13 54 94
> hc1<-hclust（dist（m）， method="ward.D"）；hc1
Call：
hclust（d = dist（m）， method = "ward.D"）
Cluster method ： ward.D
Distance ： euclidean
Number of objects： 10
> hc2<-hclust（dist（m）， method="ward.D2"）；hc2
Call：
hclust（d = dist（m）， method = "ward.D2"）
Cluster method ： ward.D2
Distance ： euclidean
Number of objects： 10
> plot（hc1） # 画图，如图3-6所示
> plot（hc2）

图3-6　比较2个聚类算法的差异

（62）sunspot.month数据集更新，sunspot.year数据集保持不变。

> head（sunspot.month）
[1] 58.0 62.6 70.0 55.7 85.0 83.5
> head（sunspot.year）
[1] 5 11 16 23 36 58

（63）summary（）函数对于lm（）一元线性回归的拟合会发出警告，因为有时候计算会不准确，这与平台相关。我在Windows中测试时，没有发现警告。

> ctl <- c（4.17，5.58，5.18，6.11，4.50，4.61，5.17，4.53，5.33，5.14）
> trt <- c（4.81，4.17，4.41，3.59，5.87，3.83，6.03，4.89，4.32，4.69）
> group <- gl（2， 10， 20， labels = c（"Ctl"，"Trt"））
> weight <- c（ctl， trt）
> lm.D9 <- lm（weight ~ group）
> summary（lm.D9）
Call：
lm（formula = weight ~ group）
Residuals：
Min 1Q Median 3Q Max
-1.0710 -0.4938 0.0685 0.2462 1.3690
Coefficients：
Estimate Std. Error t value Pr（>|t|）（Intercept） 5.0320 0.2202 22.850 9.55e-15 ***
groupTrt -0.3710 0.3114 -1.191 0.249
---
Signif. codes： 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
Residual standard error： 0.6964 on 18 degrees of freedom
Multiple R-squared： 0.07308， Adjusted R-squared： 0.02158
F-statistic： 1.419 on 1 and 18 DF， p-value： 0.249

（64）在编程中，提取summary（）函数计算出数据时，最好封装在suppressWarnings（）函数中。

> suppressWarnings（summary（lm.D9）$cov.unscaled）
（Intercept） groupTrt（Intercept） 0.1 -0.1
groupTrt -0.1 0.2

终于把这64项更新都整理完了，这些更新很多都与性能相关，另外一块是语法上的优化，看得出R语言工作的重点方向。

3.5.3　R语言3.1.1新特性及代码描述

R语言3.1.1版本的别名是Sock it to Me，很有意思。下载R3.1.1版本后，你可以通过version来查看版本信息。

~ R # 启动R程序
> version # 查看版本信息
platform x86_64-w64-mingw32
arch x86_64
os mingw32
system x86_64， mingw32
status
major 3
minor 1.1
year 2014
month 07
day 10
svn rev 66115
language R
version.string R version 3.1.1 （2014-07-10）
nickname Sock it to Me

R3.1.1版本有以下17个新特性。

（1）attach（）函数的冲突提示，与library（）函数信息提示是相似的，都使用message（）函数来实现。

> w<-women # 把women赋值给w
> w
height weight
1 58 115
2 59 117
3 60 120
4 61 123
5 62 126
6 63 129
7 64 132
8 65 135
9 66 139
10 67 142
11 68 146
12 69 150
13 70 154
14 71 159
15 72 164
> attach（w） # 加载w数据集
> height # 直接使用数据集中的height列
[1] 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72
> attach（women） # 加载women数据集，列名变量发生冲突
The following objects are masked from w：
height， weight
> library（xts） # library包加载冲突提示载入需要的程辑包：zoo载入程辑包：'zoo'
The following objects are masked from 'package：base'：
as.Date， as.Date.numeric

（2）R CMD Sweave命令，默认不再删除任何文件，并增加--clean参数设置，--clean=default和--clean=keepOuts。

~ C：\Users\Administrator>R CMD Sweave
Usage： R CMD Sweave [options] file
A front-end for Sweave and other vignette engines， via buildVignette（）
Options：
-h， --help print this help message and exit
-v， --version print version info and exit
--driver=name use named Sweave driver
--engine=pkg：：engine use named vignette engine
--encoding=enc default encoding 'enc' for file
--clean corresponds to --clean=default
--clean= remove some of the created files：
"default" removes those the same initial name；
"keepOuts" keeps e.g. *.tex even when PDF is produced
--options= comma-separated list of Sweave/engine options
--pdf convert to PDF document
--compact= try to compact PDF document：
"no" （default）， "qpdf"， "gs"， "gs+qpdf"， "both"
--compact same as --compact=qpdf
Report bugs at bugs.r-project.org

（3）tools包buildVignette（）函数和buildVignettes（）函数，当clean参数为FALSE时，不再删除新创建的文件。

> library（tools）
> buildVignette
function （file， dir = "."， weave = TRUE， latex = TRUE， tangle = TRUE，
quiet = TRUE， clean = TRUE， keep = character（）， engine = NULL，
buildPkg = NULL， ...）

（4）在Bioconductor版本中使用setRepositories（）函数，可以通过环境变量R_BIOC_VERSION在运行时设置，原来只能在R软件安装时设置（Bioconductor的版本将从2.14升级到3.0）。

（5）嵌入在Sweave文件的Sexpr代码的bug的错误信息，会显示源代码错误位置。

（6）type.convert（）函数、read.table（）函数或read.*（）函数，都增加了一个新的参数numerals，可以在读数据的时候直接转型成double，并设置数字精度。

> type.convert
function （x， na.strings = "NA"， as.is = FALSE， dec = "."， numerals = c（"allow.loss"， \
"warn.loss"， "no.loss"））
.External2（C_typeconvert， x， na.strings， as.is， dec， match.arg（numerals））
<bytecode： 0x0000000008e1b948>
<environment： namespace：utils>

（7）增加R语言内部代码的健壮性，修正一些编译器，解决了加法溢出无异常提示的问题。

> as.integer（2000000000）+as.integer（2000000000）
[1] NA
Warning message：
In as.integer（2e+09） + as.integer（2e+09） ： NAs produced by integer overflow

（8）smooth.spline（）函数的knots参数默认值改为.nknots.smspl。

> smooth.spline
function （x， y = NULL， w = NULL， df， spar = NULL， cv = FALSE，
all.knots = FALSE， nknots = .nknots.smspl， keep.data = TRUE，
df.offset = 0， penalty = 1， control.spar = list（）， tol = 1e-06 * IQR（x））

（9）Beta分布函数dbeta（，a，b）、pbeta（）、qbeta（）和rbeta（）的参数a和b默认值改为0，原来是NaN。a和b对应的参数为shape1和shape2。

> dbeta
function （x， shape1， shape2， ncp = 0， log = FALSE）
{
if （missing（ncp））
.External（C_dbeta， x， shape1， shape2， log）
else .External（C_dnbeta， x， shape1， shape2， ncp， log）
}
<bytecode： 0x000000000d54c070>
<environment： namespace：stats>

（10）RStudio的图形设备不能正常使用dev.new（）函数，给dev.new（）函数增加新的参数noRStudioGD，替换原来的默认选择，从而实现在RStudio中图形设备的开发。

> dev.new（） # 警告错误
NULL
Warning message：
In （function （） ： Only one RStudio graphics device is permitted
> dev.new（noRStudioGD=TRUE） # 弹出新窗口，运行正确

（11）增加readRDS（）函数，用于读取rds格式的数据文件。

> d<-data.frame（a=1：10，b=10：1）
> saveRDS（d， "d.rds"） # 把d数据框，以rds格式保存
> d2<-readRDS（"d.rds"） # 读取rds数据
> d2
a b
1 1 10
2 2 9
3 3 8
4 4 7
5 5 6
6 6 5
7 7 4
8 8 3
9 9 2
10 10 1

（12）当修改内部逻辑标量常数的时候，会提示错误，原来是警告。

> pi # 常数pi
[1] 3.141593
> pi<<-3.2 # 修改常数pi会出错
Error： cannot change value of locked binding for 'pi'

（13）install.packages（repos=NULL）函数，支持http或ftp协议的下载并安装新包。

> install.packages（"plyr"， repos = "http：//cran.rstudio.com/"）
trying URL 'http：//cran.rstudio.com/bin/windows/contrib/3.1/plyr_1.8.1.zip'
Content type 'application/zip' length 1151983 bytes （1.1 Mb）
opened URL
downloaded 1.1 Mb
package 'plyr' successfully unpacked and MD5 sums checked
The downloaded binary packages are in
C：\Users\Administrator\AppData\Local\Temp\RtmpWEXnOT\downloaded_packages

（14）当R环境变量options（"warnPartialMatchDollar"）为TRUE时，数据框用$符号部分匹配会出现警告。

> options（"warnPartialMatchDollar"） # 默认值
$warnPartialMatchDollar
NULL
> options（warnPartialMatchDollar = TRUE） # 赋值设为TRUE
> options（"warnPartialMatchDollar"）
$warnPartialMatchDollar
[1] TRUE
> df <- data.frame（ab=1：4，cd=1：4）
> rownames（df） <- paste0（letters[1：4]，"a"）
> df$a # 警告
[1] 1 2 3 4
Warning message：
In `$.data.frame`（df， a） ： Partial match of 'a' to 'ab' in data frame
> df["a"，] # 另一种调用方法

（15）通过packagefoo的语法来查询包的信息，而不管包是否被加载。

> search（） # 当前环境已加载的包，不包括plyr
[1] ".GlobalEnv" "tools：rstudio" "package：stats"
[4] "package：graphics" "package：grDevices" "package：utils"
[7] "package：datasets" "package：methods" "Autoloads"
[10] "package：base"
> packageplyr # 可以直接打开plyr的包帮助
> packagepryr
Error in ``（package， pryr） ：

注意，没有种类为‘package’和名为‘pryr’的文件（或是在处理帮助文件时发生了错误）。

（16）调用R的帮助，现在默认会尝试所有加载的包，而不仅仅是在搜索路径。

> help（package="zoo"） # 查看未加载包的信息
> zoo # 查看未加载包中，所有名字匹配的函数

（17）增加promptImport（）函数，用于从其他包导出一个帮助文件。

> promptImport（cat） # 导出cat函数的帮助文件

建立一名字叫‘cat.Rd’的文件。修改文件再把它放到合适的目录中去。查看生成cat.Rd文件。

\name{cat}
\alias{cat}
\docType{import}
\title{Import from package \pkg{base}}
\description{
The \code{cat} object is imported from package \pkg{base}.
Help is available here： \code{\link[base：cat]{base：：cat}}.
}

对于R 3.1.1版本的更新，一部分增加新功能，另外有些更新其实是在给3.1.0版本修补bug。

对于想深入学习R语言的用户来说，每次更新升级都需要看一遍新特性列表，真是很有必要的，很多时候都可以解决我们实际遇到的问题。比如，R3.1.1版本第10个更新对RStudio图形输出的支持，就可以解决我在RStudio中由于图形设备环境出错，不能启动游戏界面的问题。

补充一句，由于每个更新点官方仅有一句话描述，而我的知识水平有限，也并不是所有都能理解，书中难免有理解错误的地方，如果有读者发现错误，还请指教。

第4章　面向对象编程

本章详细介绍了R语言中面向对象的编程思路，以及4种面向对象体系结构的编程实现，帮助读者深入理解R语言的面向对象编程，并有能力构建出复杂的业务应用。

4.1　R语言面向对象编程

问题

如何理解R语言中的面向对象？

引言

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

4.1.1　什么是面向对象

面向对象是指一种程序设计范型，同时也是一种程序开发的方法。面向对象的对象指的是类的集合，把对象作为程序的基本单元，将程序和数据封装其中，以提高软件的重用性、灵活性和扩展性。面向对象是一种对现实世界理解和抽象的方法，是计算机编程技术发展到一定阶段的产物。早期的计算机编程是基于面向过程的方法，例如实现算术运算2+3+4=9，通过设计一次运算就可以计算出结果。

随着计算机技术的不断发展，计算机被用来解决越来越复杂的问题。一切事物皆对象，通过面向对象的方法，将现实世界的事物抽象成对象，现实世界中的关系抽象成对象之间的关系，如继承关系，从而帮助人们实现对现实世界的抽象与数字建模。通过面向对象的方法，更方便利用人们理解的复杂系统的分析、设计与编程过程。同时，面向对象能有效提高编程的效率，通过封装、继承、多态的抽象，可以像搭积木一样快速开发出一个全新的系统。

1.面向对象的三个特征

面向对象的三个特征是封装、继承、多态。封装是把客观事物封装成抽象的类，并且类可以把自己的数据和方法只让可信的类或者对象操作，对不可信的类或对象操作进行信息隐藏。一个封装实例，如图4-1所示。

图4-1　封装

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

·老师的行为：讲课、布置作业、批作业。

·学生的行为：听课、写作业、考试。

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

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

图4-2　继承

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

多态是指由继承而产生的相关的不同的类，其对象对同一消息会做出不同的响应。一个多态实例，如图4-3所示。

图4-3　多态

期末考试时，总有考得好的同学和考得不好的同学。所以，对于优等生来说，他的考试结果是优；对次等生来说，考试结果就不是太好。相同行为对于由继承而产生的相关的不同的对象，结果是不同的。所以，通过面向对象的思想，我们可以把客观世界的事物进行抽象。

2.is a和has a

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

·is a：为继承关系，比如菱形、圆形和方形都是一种形状。

·has a：为组合关系或聚合关系，比如电脑由显示器、CPU、硬盘等组成。

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

R主要面向统计计算，而且代码量一般不会很大，也就几十行或几百行，使用面向过程的编程方法就可以很好地完成编程的任务。但R语言的持续走热，并伴随着越来越多拥有工程背景的人加入，R语言开始向更多的领域发展。原来少量代码的面向过程的编码方式，会越来越难以维护具有海量代码的项目，所以必须有一种新的编程方式来取代原来的面向过程的编码思路，这种新的编程方式就是面向对象编程（Object Oriented Programming，OOP）。

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

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

我想这个答案就是以面向对象的方式进行编程，现在的R就像8年前的JavaScript，需要大公司和牛人来推动。从我的观察来看，以Hadley Wickham为代表的R语言领军人物已经开始在R包中全面引入面向对象思路进行R包的开发了。关于以面向对象思想开发的R包memoise，请参考《R的极客理想——工具篇》一书的3.1节。

4.1.3　R的面向对象编程

R语言中有三种面向对象的编程实现，即S3类型、S4类型和RC类型。S3和S4都是基于泛型函数的，RC则是完全的面向对象实现。这三种面向对象类型的使用，在本章中都会介绍，而本节以S3类型为切入点，接下来介绍的面向对象的实现方式都是基于S3类型来说的。

R语言中基于S3类型的面向对象编程是通过泛型函数（generic function）实现的，而不是基于类层次结构。接下来，我从面向对象的三个特征入手，分别用R语言进行实现，使用的案例为前面提到的老师和学生的三幅图。

1.R语言实现封装

定义老师对象和行为，封装到teacher（）泛型函数中；定义同学对象和行为，封装到student（）泛型函数中。

# 定义老师对象和行为
> 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] "写作业"

从执行结果可以看到，这个同时有老师和同学的行为变量ab，被teacher（）泛型函数调用时就是老师的行为，被student（）泛型函数调用时就是同学的行为。

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（'attend'，'homework'，'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] "attend" "homework" "exam"
> s2 # 查看课代表的对象实例
[1] "课代表"
attr（，"type"）
[1] "leader" "StudentObj"
attr（，"class"）
[1] "attend" "homework" "exam" "correcting"

3.R语言实现多态

期末考试时，有的同学考试成绩好，有的同学考试成绩不好，我们通过继承构造出优等生和次等生两个实例。两个实例有相同行为，但对于考试的结果是不同的，这样就体现出了多态的特征。

> e1 <- NewInstance（'优等生'，classes='excellent'， parents='StudentObj'）
# 创建优等生和次等生两个实例
> e2 <- NewInstance（'次等生'，classes='poor'， parents='StudentObj'）
> student.exam <- function（x，score） { # 修改同学考试的行为，大于85分结果为优秀，
# 小于70分结果为及格
+ p<-"考试"
+ if（score>85） print（paste（p，"优秀"，sep=""））
+ if（score<70） print（paste（p，"及格"，sep=""））
+ }
> attr（e1，'class'） <- 'exam' # 执行优等生的考试行为，并输入分数为90
> student（e1，90）
[1] "考试优秀"
> attr（e2，'class'） <- 'exam' # 执行次等生的考试行为，并输入分数为66
> student（e2，66）
[1] "考试及格"

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

4.R的面向过程编程

接下来，为了对比，我们用R语言的面向过程的代码实现上面的逻辑。

（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] "听课"

（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（）函数的同时，已经增加了原函数的复杂度。

（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"）
+ }
+ }
> student_fun（'exam'，score=90） # 执行考试函数，考试成绩大于85分，为优等生
[1] "考试优秀"
> student_fun（'exam'，score=66） # 执行考试函数，考试成绩小于70分，为次等生
[1] "考试及格"

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

本节抛砖引玉地讲了R语言的面向对象的编程，其中部分代码有些不够严谨，本节只希望给大家思路上的认识，更具体的面向对象编程实例会在下一节中详细介绍。

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

问题

如何基于S3系统进行面向对象编程？

引言

就面向对象编程，R语言不同于其他的编程语言，R语言提供了三种底层对象系统，一种是S3类型，一种是S4类型，还有一种是RC类型。S3对象简单，具有动态性，但结构化特征不明显；S4对象结构化，功能强大；RC对象是2.12版本后使用的新类型，用于解决S3和S4很难实现的对象设计。本节将从S3对象开始，介绍R语言面向对象编程的细节。

4.2.1　创建S3对象

在R语言中，基于S3对象的面向对象编程，是一种基于泛型函数的实现方式。泛型函数是一种特殊的函数，根据传入对象的类型决定调用哪个具体的方法。基于S3对象实现的面向对象编程，不同于其他语言的面向对象编程，是一种动态函数调用的模拟实现。S3对象被广泛应用于R的早期的开发包中。关于面向对象的基础知识介绍，请参看4.1节。

本节的系统环境是：

·Linux：Ubuntu Server 12.04.2 LTS 64bit

·R：3.1.1 x86_64-pc-linux-gnu（64-bit）

为了方便我们检查对象的类型，引入pryr包作为辅助工具。关于pryr包的介绍，请参看3.1节。

~ R # 启动R程序
> library（pryr） # 加载pryr包

1.通过变量创建S3对象

创建S3对象最简单的方法就是给一个变量增加class属性。

> x<-1 # 定义变量
> attr（x，'class'）<-'foo' # 定义为S3类型对象

> x # 查看变量
[1] 1
attr（，"class"）
[1] "foo"
> class（x） # 查看变量类型
[1] "foo"
> otype（x） # 用pryr包的otype函数检查x的类型
[1] "S3"

也可以通过structure（）函数创建S3对象。

> y <- structure（2， class = "foo"） # 创建S3类型对象
> y
[1] 2 # 查看变量
attr（，"class"）
[1] "foo"
> class（y） # 查看变量类型
[1] "foo"
> otype（y） # 用pryr包的otype函数检查y的类型
[1] "S3"

2.创建一个多类型的S3对象

S3对象没有明确的结构关系，一个S3对象可以有多个类型。S3对象类型，通过变量的class属性来定义，class属性可以是一个向量，所以允许多类型。

> x<-1 # 定义变量
> attr（x，'class'）<- c（"foo"， "bar"） # 设置多个S3类型
> class（x） # 查看变量x类型
[1] "foo" "bar"
> otype（x） # 查看变量x类型
[1] "S3"

4.2.2　泛型函数和方法调用

对于S3对象的使用，通常用UseMethod（）函数来定义一个泛型函数的名称，通过传入参数的class属性来确定不同的方法调用。下面我们创建一个S3类型的泛型函数，定义一个名为teacher的泛型函数，用于S3对象的调用。

·用UseMethod（）定义teacher泛型函数。

·用teacher.xxx的语法格式定义teacher对象的行为，其中teacher.default是默认行为。

> teacher <- function（x， ...） UseMethod（"teacher"） # 用UseMethod（）定义teacher
# 泛型函数
> ftype（teacher） # 用pryr包中的ftype（）函数检查teacher的类型
[1] "s3" "generic"
> teacher.lecture <- function（x） print（"讲课"） # 定义teacher内部函数
> teacher.assignment <- function（x） print（"布置作业"）
> teacher.correcting <- function（x） print（"批改作业"）
> teacher.default<-function（x） print（"你不是teacher"） # 定义teacher的默认行为函数

方法调用时，通过传入参数的class属性来确定不同的方法调用。

·定义一个变量a，并设置a的class属性为lecture。

·把变量a传入teacher泛型函数中。

·teacher.lecture（）函数的行为被调用。

> a<-'teacher' # 定义一个变量a
> attr（a，'class'） <- 'lecture' # 把变量a的值设置为行为
> teacher（a） # 执行老师的行为
[1] "讲课"

当然，我们也可以直接调用teacher中定义的行为，如果这样做就失去了面向对象封装的意义。

> teacher.lecture（）
[1] "讲课"
> teacher.lecture（a）
[1] "讲课"
> teacher（） # 如果参数的class类型不是已经定义的，则执行默认行为函数
[1] "你不是teacher"

对比其他语言，这里R的泛型函数就表示方法接口，teacher.xxx表示接口的方法实现。

4.2.3　查看S3对象的函数

当我们使用S3对象进行面向对象封装后，可以用methods（）函数来查看S3对象中定义的内部行为函数。

> teacher # 查看teacher对象
function（x， ...） UseMethod（"teacher"）
> methods（teacher） # 查看teacher对象的内部函数
[1] teacher.assignment teacher.correcting teacher.default teacher.lecture

通过methods（）的generic.function参数来匹配泛型函数名字。

> methods（generic.function=predict） # 找到环境空间中以predict开头的S3类型的函数
[1] predict.ar* predict.Arima* predict.arima0*
[4] predict.glm predict.HoltWinters* predict.lm
[7] predict.loess* predict.mlm predict.nls*
[10] predict.poly predict.ppr* predict.prcomp*
[13] predict.princomp* predict.smooth.spline* predict.smooth.spline.fit*
[16] predict.StructTS*
Non-visible functions are asterisked

通过methods（）的class参数来匹配类的名字。

> methods（class=lm） # 找到环境空间中以lm为class属性的S3类型的对象
[1] add1.lm* alias.lm* anova.lm case.names.lm*
[5] confint.lm* cooks.distance.lm* deviance.lm* dfbeta.lm*
[9] dfbetas.lm* drop1.lm* dummy.coef.lm* effects.lm*
[13] extractAIC.lm* family.lm* formula.lm* hatvalues.lm
[17] influence.lm* kappa.lm labels.lm* logLik.lm*
[21] model.frame.lm model.matrix.lm nobs.lm* plot.lm
[25] predict.lm print.lm proj.lm* qr.lm*
[29] residuals.lm rstandard.lm rstudent.lm simulate.lm*
[33] summary.lm variable.names.lm* vcov.lm*
Non-visible functions are asterisked

用getAnywhere（）函数查看所有的函数。

> getAnywhere（teacher.lecture） # 查看teacher.lecture（）函数
A single object matching 'teacher.lecture' was found
It was found in the following places
.GlobalEnv
registered S3 method for teacher
with value
function（x） print（"讲课"）
> predict.ppr # 查看不可见的函数predict.ppr
Error： object 'predict.ppr' not found
> exists（"predict.ppr"）
[1] FALSE
> getAnywhere（"predict.ppr"） # getAnywhere（）函数查找predict.ppr
A single object matching 'predict.ppr' was found
It was found in the following places
registered S3 method for predict from namespace stats
namespace：stats
with value
function （object， newdata， ...）
{
if （missing（newdata））
return（fitted（object））
if （！is.null（object$terms）） {
newdata <- as.data.frame（newdata）
rn <- row.names（newdata）
Terms <- delete.response（object$terms）
m <- model.frame（Terms， newdata， na.action = na.omit，
xlev = object$xlevels）
if （！is.null（cl <- attr（Terms， "dataClasses"）））
.checkMFClasses（cl， m）
keep <- match（row.names（m）， rn）
x <- model.matrix（Terms， m， contrasts.arg = object$contrasts）
}
else {
x <- as.matrix（newdata）
keep <- seq_len（nrow（x））
rn <- dimnames（x）[[1L]]
}
if （ncol（x） ！= object$p）
stop（"wrong number of columns in 'x'"）
res <- matrix（NA， length（keep）， object$q， dimnames = list（rn，
object$ynames））
res[keep， ] <- matrix（.Fortran（C_pppred， as.integer（nrow（x）），
as.double（x）， as.double（object$smod）， y = double（nrow（x） *
object$q）， double（2 * object$smod[4L]））$y， ncol = object$q）
drop（res）
}
<bytecode： 0x000000000df6c2d0>
<environment： namespace：stats>

同样，使用getS3method（）函数也可以查看不可见的函数。

> getS3method（"predict"， "ppr"） # getS3method（）函数查找predict.ppr
function （object， newdata， ...）
{
if （missing（newdata））
return（fitted（object））
if （！is.null（object$terms）） {
newdata <- as.data.frame（newdata）
rn <- row.names（newdata）
Terms <- delete.response（object$terms）
m <- model.frame（Terms， newdata， na.action = na.omit，
xlev = object$xlevels）
if （！is.null（cl <- attr（Terms， "dataClasses"）））
.checkMFClasses（cl， m）
keep <- match（row.names（m）， rn）
x <- model.matrix（Terms， m， contrasts.arg = object$contrasts）
}
else {
x <- as.matrix（newdata）
keep <- seq_len（nrow（x））
rn <- dimnames（x）[[1L]]
}
if （ncol（x） ！= object$p）
stop（"wrong number of columns in 'x'"）
res <- matrix（NA， length（keep）， object$q， dimnames = list（rn，
object$ynames））
res[keep， ] <- matrix（.Fortran（C_pppred， as.integer（nrow（x）），
as.double（x）， as.double（object$smod）， y = double（nrow（x） *
object$q）， double（2 * object$smod[4L]））$y， ncol = object$q）
drop（res）
}
<bytecode： 0x000000000df6c2d0>
<environment： namespace：stats>

4.2.4　S3对象的继承调用方式

S3对象有一种非常简单的继承调用方式，用NextMethod（）函数来实现。下面定义一个node（）泛型函数。

> node <- function（x） UseMethod（"node"， x）
> node.default <- function（x） "Default node"
> node.father <- function（x） c（"father"） # father函数
> node.son <- function（x） c（"son"， NextMethod（）） # son函数，通过NextMethod（）
# 函数指向father函数
> n1 <- structure（1， class = c（"father"）） # 定义n1
> node（n1） # 在node函数中传入n1，执行node.father（）函数
[1] "father"
> n2 <- structure（1， class = c（"son"， "father"）） # 定义n2，设置class属性为两个
> node（n2） # 在node函数中传入n2，执行node.son（）函数和node.father（）函数
[1] "son" "father"

通过对node（）函数传入n2的参数，node.son（）先被执行，然后通过NextMethod（）函数继续执行node.father（）函数。其实这样就模拟了子函数调用父函数的过程，实现面向对象编程中的继承。

4.2.5　S3对象的缺点

从上面对S3对象的介绍来看，S3对象并不是完全的面向对象实现，而是一种通过函数调用来模拟面向对象实现。

·S3使用起来简单，但在实际的面向对象编程过程中，当对象关系有一定的复杂度时，S3对象所表达的意义就会变得不太清楚。

·S3封装的内部函数可绕过泛型函数的检查直接被调用。

·S3参数的class属性可以被任意设置，没有预处理的检查。

·S3参数只能通过调用class属性进行函数调用，其他属性则不会被class（）函数执行。

·S3参数的class属性有多个值时，调用时会按照程序赋值顺序来调用第一个合法的函数。

所以，S3只是R语言面向对象的一种简单实现。

4.2.6　S3对象的使用

S3对象系统被广泛地应用于R语言的早期开发中。在base包中，就有很多的S3对象。

查看base包的S3对象。

> mean # mean函数
function （x， ...）
UseMethod（"mean"）
<bytecode： 0x3f8e0f0>
<environment： namespace：base>
> ftype（mean）
[1] "s3" "generic"
> ftype（t） # t函数
[1] "s3" "generic"
> ftype（plot） # plot函数
[1] "s3" "generic"

自定义的S3对象。

> a <- 1 # 定义数字型变量a
> class（a） # 变量a的class为numeric
[1] "numeric"
> f1 <- function（x） { # 定义泛型函数f1
+ a <- 2
+ UseMethod（"f1"）
+ }
> f1.numeric <- function（x） a # 定义f1的内部函数
> f1（a） # 给f1（）传入变量a
[1] 2
> f1（99） # 给f1（）传入数字99
[1] 2
> f1.character <- function（x） paste（"char"， x） # 定义f1的内部函数
> f1（"a"） # 给f1（）传入字符a
[1] "char a"

通过本节的介绍，我们对S3对象系统有了一个全面认识，开始R语言的面向对象编程之路。下一节将介绍R语言的S4对象系统。

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

问题

如何基于S4系统进行面向对象编程？

引言

继续上一节的内容，本节将介绍R语言基于S4的面向对象编程。S4对象系统具有明显的结构化特征，更适合面向对象的程序设计。Bioconductor社区，以S4对象系统作为基础架构，只接受符合S4定义的R包。

4.3.1　创建S4对象

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

本节的系统环境是：

·Linux：Ubuntu Server 12.04.2 LTS 64bit

·R：3.1.1 x86_64-pc-linux-gnu（64-bit）

为了方便我们检查对象的类型，引入pryr包作为辅助工具。关于pryr包的介绍，请参看3.1节。

~ R # 启动R程序
> library（pryr） # 加载pryr包

1.如何创建S4对象？

S4对象系统有专门的类定义函数setClass（）和类的实例化函数new（），下面我们看看setClass（）和new（）是如何使用的。首先，查看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以后不建议使用。

通过setClass（）函数我们就可以创建一个S4类型的对象结构了。

> setClass（"Person"，slots=list（name="character"，age="numeric"）） # 定义一个S4对象

2.创建一个S4对象实例

通过setClass（）函数定义好类的结构，再通过new（）函数来实例化类对象。

> father<-new（"Person"，name="F"，age=44） # 实例化一个Person对象
> father # 查看father对象，有两个属性name和age
An object of class "Person"
Slot "name"：
[1] "F"
Slot "age"：
[1] 44
> class（father） # 查看father对象类型，为Person
[1] "Person"
attr（，"package"）
[1] ".GlobalEnv"
> otype（father） # 查看father对象为S4的对象
[1] "S4"

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

如果需要创建有继承关系的S4对象，可以通过setClass（）函数的contains属性来设置父类。

> setClass（"Person"，slots=list（name="character"，age="numeric"））
# 创建一个S4对象Person
> setClass（"Son"，slots=list（father="Person"，mother="Person"），contains="Person"）
# 创建Person的子类
> father<-new（"Person"，name="F"，age=44） # 实例化Person对象
> mother<-new（"Person"，name="M"，age=39）
> son<-new（"Son"，name="S"，age=16，father=father，mother=mother） # 实例化一个Son对象
> 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
> slot（son，"mother"） # 查看son对象的mother属性
An object of class "Person"
Slot "name"：
[1] "M"
Slot "age"：
[1] 39
> otype（son） # 检查son类型
[1] "S4"
> otype（son@name） # 检查son@name属性类型
[1] "primitive"
> otype（son@mother） # 检查son@mother属性类型
[1] "S4"
> isS4（son） # 用isS4（）检查S4对象的类型
[1] TRUE
> isS4（son@name）
[1] FALSE
> isS4（son@mother）
[1] TRUE

4.S4对象的默认值

我们定义类时，类一般都会包括属性字段（slots），通过setClass（）函数的prototype属性给属性字段中定义的参数设置默认值。

> setClass（"Person"，slots=list（name="character"，age="numeric"））
> a<-new（"Person"，name="a"） # 属性age为空
> a
An object of class "Person"
Slot "name"：
[1] "a"
Slot "age"：
numeric（0）
> setClass（"Person"，slots=list（name="character"，age="numeric"），prototype = list（age = 20））
# 设置属性age的默认值为20
> b<-new（"Person"，name="b"） # 属性age为空
> b # 属性age的默认值是20
An object of class "Person"
Slot "name"：
[1] "b"
Slot "age"：
[1] 20

5.S4对象的类型检查

通过setValidity（）函数给属性字段中定义的参数设置类型检查。

> setClass（"Person"，slots=list（name="character"，age="numeric"））
> bad<-new（"Person"，name="bad"，age="abc"） # 传入错误的age类型
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"
> setValidity（"Person"，function（object） { # 设置age的非负检查
+ if （object@age <= 0） stop（"Age is negative."）
+ }）
Class "Person" [in ".GlobalEnv"]
Slots：
Name： name age
Class： character numeric
> bad2<-new（"Person"，name="bad"，age=-1） # 修正传入小于0的年龄
Error in validityMethod（object） ： Age is negative.

6.从一个已实例化的对象中创建新对象

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

> setClass（"Person"，slots=list（name="character"，age="numeric"））
> n1<-new（"Person"，name="n1"，age=19）；n1 # 创建一个对象实例n1
An object of class "Person"
Slot "name"：
[1] "n1"
Slot "age"：
[1] 19
> n2<-initialize（n1，name="n2"）；n2 # 从实例n1中创建实例n2，并修改name的属性值
An object of class "Person"
Slot "name"：
[1] "n2"
Slot "age"：
[1] 19

4.3.2　访问S4对象的属性

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

> setClass（"Person"，slots=list（name="character"，age="numeric"））
> a<-new（"Person"，name="a"）
> a@name # 访问S4对象的属性
[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.3.3　S4的泛型函数

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

普通函数的定义和调用。

> work<-function（x） cat（x， "is working"）
> work（'Conan'）
Conan is working

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

> setClass（"Person"，slots=list（name="character"，age="numeric"）） # 定义Person对象
> setGeneric（"work"，function（object） standardGeneric（"work"）） # 定义泛型函数work，即接口
> setMethod（"work"， signature（object = "Person"）， function（object） cat（object@name ，
"is working"） ） # 定义work的实现函数，并指定参数类型为Person对象
[1] "work"
> a<-new（"Person"，name="Conan"，age=16） # 创建一个Person对象a
> work（a） # 把对象a传入work函数
Conan is working

通过S4对象系统，把原来的函数定义及调用过程从2步变成4步：（1）定义数据对象类型；（2）定义接口函数；（3）定义实现函数；（4）把数据对象以参数传入接口函数，执行实现函数。所以，S4对象系统是一个结构化的面向对象实现。

4.3.4　查看S4对象的函数

当我们使用S4对象进行面向对象封装后，我们还需要能查看S4对象的定义和函数定义。下面继续使用前面Person和work的例子中定义的数据对象。

> ftype（work） # 检查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.
> showMethods（work） # 查看work函数的现实定义
Function： work （package .GlobalEnv）
object="Person"
> getMethod（"work"， "Person"） # 查看Person对象的work函数现实
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"
> existsMethod（"work"， "Person"） # 检查Person对象有没有work函数
[1] TRUE
> hasMethod（"work"， "Person"）
[1] TRUE

4.3.5　S4对象的使用

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

1.任务一：定义图形库的数据结构和计算函数

假设最底层以Shape图形为基类，包括圆形和椭圆形，并计算出它们的面积和周长。

·定义图形库的数据结构

·定义圆形的数据结构，并计算面积和周长

·定义椭圆形的数据结构，并计算面积和周长

结构如图4-4所示。

图4-4　任务一：图形库的数据结构

我们首先定义基类Shape和圆形类（Circle）。

> setClass（"Shape"，slots=list（name="character"）） # 定义基类Shape
> setClass（"Circle"， # 定义圆形类Circle，继承Shape，属性radius默认值为1
+ contains="Shape"，
+ slots=list（radius="numeric"），
+ prototype=list（radius = 1））
> setValidity（"Circle"，function（object）{ # 验证radius属性值要大等于0，当小于等于
# 0时就退出
+ 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"
> area（c1） # 分别计算c1和c2两个圆形的面积
[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
+ }）
[1] "circum" # 分别计算c1和c2两个圆形的周长
> 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）））
> setValidity（"Ellipse"，function（object） { # 验证radius参数
+ 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<-new（"Ellipse"，name="e1"） # 创建两个椭圆形实例e1和e2
> e2<-new（"Ellipse"，name="e2"，radius=c（5，1））
> setMethod（"area"， "Ellipse"，function（obj，...）{ # 计算椭圆形面积的函数现实
+ print（"Area Ellipse Method"）
+ pi * prod（obj@radius）
+ }）
[1] "area"
> area（e1） # 计算e1和e2两个椭圆形的面积
[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"
> circum（e1） # 计算e1和e2两个椭圆形的周长
Ellipse Circum ：
[1] 6.283185
> circum（e2）
Ellipse Circum ：
[1] 22.65435

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

2.任务二：重构圆形和椭圆形的设计

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

> setClass（"Shape"， # 基类Shape
+ slots=list（name="character"））
> setClass（"Ellipse"， # Ellipse继承Shape
+ contains="Shape"，
+ slots=list（radius="numeric"），
+ prototype=list（radius=c（1，1）））
> setClass（"Circle"， # Circle继承Ellipse
+ contains="Ellipse"，
+ slots=list（radius="numeric"），
+ prototype=list（radius = 1））
> setGeneric（"area"，function（obj，...） standardGeneric（"area"）） # 定义area接口
[1] "area"
> setMethod（"area"，"Ellipse"，function（obj，...）{ # 定义area的Ellipse实现
+ cat（"Ellipse Area ：\n"）
+ pi * prod（obj@radius）
+ }）
[1] "area"
> setMethod（"area"，"Circle"，function（obj，...）{ # 定义area的Circle实现
+ cat（"Circle Area ：\n"）
+ pi*obj@radius^2
+ }）
[1] "area"
> setGeneric（"circum"，function（obj，...） standardGeneric（"circum"）） # 定义circum接口
[1] "circum"
> setMethod（"circum"，"Ellipse"，function（obj，...）{ # 定义circum的Ellipse实现
+ cat（"Ellipse Circum ：\n"）
+ 2*pi*sqrt（（obj@radius[1]^2+obj@radius[2]^2）/2）
+ }）
[1] "circum"
> setMethod（"circum"，"Circle"，function（obj，...）{ # 定义circum的Circle实现
+ 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

我们重构后的结构是不是更合理呢！

3.任务三：增加矩形的图形处理

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

·定义矩形的数据结构，并计算面积和周长。

·定义正方形的数据结构，并计算面积和周长。

·正方形是矩形的特例，定义矩形是正方形的父类，而正方形是矩形的子类。

结构如图4-6所示。

图4-5　任务二：重构椭圆形的数据结构

图4-6　任务三：矩形的数据结构

> setClass（"Rectangle"， # 定义矩形Rectangle，继承Shape
+ contains="Shape"，
+ slots=list（edges="numeric"），
+ prototype=list（edges=c（1，1）））
> setClass（"Square"， # 定义正方形Square，继承Rectangle
+ contains="Rectangle"，
+ slots=list（edges="numeric"），
+ prototype=list（edges=1））
> setMethod（"area"，"Rectangle"，function（obj，...）{# 定义area的Rectangle实现
+ cat（"Rectangle Area ：\n"）
+ prod（obj@edges）
+ }）
[1] "area"
> setMethod（"area"，"Square"，function（obj，...）{ # 定义area的Square实现
+ cat（"Square Area ：\n"）
+ obj@edges^2
+ }）
[1] "area"
> setMethod（"circum"，"Rectangle"，function（obj，...）{ # 定义circum的Rectangle实现
+ cat（"Rectangle Circum ：\n"）
+ 2*sum（obj@edges）
+ }）
[1] "circum"
> setMethod（"circum"，"Square"，function（obj，...）{ # 定义circum的Square实现
+ 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种图形了！用面向对象的结构来设计，是不是结构化思路很清晰呢！

4.任务四：在基类Shape中增加shape属性和getShape方法

接下来，要对图形库的所有图形增加一个图形类型的变量shape，然后再提供一个getShape函数可以检查实例中的是shape变量。结构如图4-7所示。

图4-7　任务四：完成图形库的数据结构

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

> setClass（"Shape"， # 重新定义基类Shape，增加shape属性
+ slots=list（name="character"，shape="character"））
> setGeneric（"getShape"，function（obj，...） standardGeneric（"getShape"））
# 定义getShape接口
[1] "getShape"
> setMethod（"getShape"，"Shape"，function（obj，...）{ # 定义getShape实现
+ cat（obj@shape，"\n"）
+ }）
[1] "getShape"

其实，这样改动一个就可以，我们只需要重新实例化每个图形的对象就行。如果我们再多做一步，可以修改每个对象的定义，增加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"））
> s1<-new（"Square"，name="s1"，edges=2， shape="Square"） # 实例化一个Square对象，并
# 给shape属性赋值
> getShape（s1） # 调用基类的getShape（）函数
Square

是不是很容易呢只在代码对应的地方进行修改，所有的图形就有了对应的属性和方法。下面是完整的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对象系统的面向对象程序设计，有没有找到相通的感觉呢？在程序员的世界里，世间万物都可以抽象成对象。

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

问题

如何基于RC面向对象系统编程？

引言

继续上一节的内容，本节将介绍R语言基于RC的面向对象编程。RC对象系统从底层上改变了原有S3和S4对象系统的设计，去掉了泛型函数，真正地以类为基础实现面向对象的特征。

4.4.1　RC对象系统介绍

RC是Reference classes的简称，又被称为R5，在R语言的2.12版本被引入，是R语言最新一代的面向对象系统。RC不同于原来的S3和S4对象系统，RC对象系统的方法是在类中自定的，而不是泛型函数。RC对象的行为更类似于其他的编程语言，实例化对象的语法也有所改变。但由于RC对象系统还是依赖于S4对象系统，我们可以简单地理解为RC是对S4的更进一步的面向对象封装。从面向对象的角度来说，我们下面要重定义几个名词。

·类：面向对象系统的基本类型，类是静态结构定义。

·对象：类实例化后，在内存中生成结构体。

·方法：是类中的函数定义，不通过泛型函数实现。

4.4.2　创建RC类和对象

本节的系统环境是：

·Linux：Ubuntu Server 12.04.2 LTS 64bit

·R：3.1.1 x86_64-pc-linux-gnu（64-bit）

为了方便我们检查对象的类型，引入pryr包作为辅助工具。关于pryr包的介绍，请参看3.1节。

~ R # 启动R程序
> library（pryr） # 加载pryr包

1.如何创建RC类

RC对象系统以类为基本类型，有专门的类的定义函数setRefClass（）和实例化对象的生成方法，下面我们介绍如何用RC对象系统创建一个类。

查看RC的类创建函数setRefClass（）函数的定义。

setRefClass（Class， fields = ， contains = ， methods =， where =， ...）

各参数解释如下：

·Class：定义类名

·fields：定义属性和属性类型

·contains：定义父类，继承关系

·methods：定义类中的方法

·where：定义存储空间

从setRefClass（）函数的定义来看，其参数比S4的setClass（）函数的参数少。

2.创建RC类和实例

> User<-setRefClass（"User"，fields=list（name="character"）） # 定义一个RC类
> 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"

下面我们实例化一个RC对象。

> u1<-User$new（name="u1"） # 实例化一个User对象u1
> u1 # 查看u1对象
Reference class object of class "User"
Field "name"：
[1] "u1"
> class（User） # 检查User类的类型
[1] "refObjectGenerator"
attr（，"package"）
[1] "methods"
> is.object（User）
[1] TRUE
> otype（User）
[1] "RC"
> class（u1） # 检查u1的类型
[1] "User"
attr（，"package"）
[1] ".GlobalEnv"
> is.object（u1）
[1] TRUE
> otype（u1）
[1] "RC"

3.创建一个有继承关系的RC

> User<-setRefClass（"User"，
+ fields=list（name="character"）） # 创建RC类User
> Member<-setRefClass（"Member"， # 创建User的子类Member
+ contains="User"，
+ fields=list（manager="User"））
> manager<-User$new（name="manager"） # 实例化User
> member<-Member$new（name="member"，manager=manager） # 实例化一个Son对象
> 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"

4.RC对象的默认值

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

# 定义一个RC类
> User<-setRefClass（"User"，
+ fields=list（name="character"，level='numeric'）， # 定义2个属性
+ methods=list（
+ initialize = function（name，level）{ # 构造方法
+ print（"User：：initialize"）
+ name <<- 'conan' # 给属性增加默认值
+ level <<- 1
+ }
+ ）
+ ）
> u1<-User$new（） # 实例化对象u1
[1] "User：：initialize"
> u1 # 查看对象u1，属性被增加了默认值
Reference class object of class "User"
Field "name"：
[1] "conan"
Field "level"：
[1] 1

4.4.3　对象赋值

> User<-setRefClass（"User"， # 定义User类
+ fields=list（name="character"，age="numeric"，gender="factor"））
> genderFactor<-factor（c（'F'，'M'）） # 定义一个factor类型
> u1<-User$new（name="u1"，age=44，gender=genderFactor[1]） # 实例化u1
> u1$age # 查看age属性值
[1] 44

给u1的age属性赋值。

> u1$age<-10 # 重新赋值
> u1$age # age属性改变
[1] 10

把u1对象赋值给u2对象。

> u2<-u1 # 把u1赋值给u2对象
> u2$age # 查看u2的age属性
[1] 10
> u1$age<-20 # 重新赋值
> u1$age # 查看u1，u2的age属性，都发生改变
[1] 20
> u2$age
[1] 20

由于把u1赋值给u2的时候，传递的是u1的实例化对象的引用，而不是值本身，所以属性发生改变。这一点与其他语言中对象赋值是一样的。如果想进行赋值而不是引用传递，可以用下面的方法实现。

> u3<-u1$copy（） # 调用u1的内置方法copy（），赋值给u3
> u3$age # 查看u3的age属性
[1] 20
> u1$age<-30 # 重新赋值
> u1$age # 查看u1的age属性，发生改变
[1] 30
> u3$age # 查看u3的age属性，没有改变
[1] 20

掌握好对象的引用关系，不仅可以减少值传递过程中的内存复制过程，而且还让我们的程序运行效率更高。

4.4.4　定义对象的方法

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

> User<-setRefClass（"User"， # 定义一个RC类，包括方法
+ 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<-User$new（name="u1"，favorite=c（'movie'，'football'）） # 实例化对象u1
> 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"

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

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

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

1.内置方法

RC对象有以下13个内置方法。

·initialize，类的初始化函数，用于设置属性的默认值，只能在类定义的方法中使用。

·callSuper，调用父类的同名方法，只能在类定义的方法中使用。

·copy，复制实例化对象的所有属性。

·initFields，给对象的属性赋值。

·field，查看属性或给属性赋值。

·getClass，查看对象的类定义。

·getRefClass，同getClass。

·show，查看当前对象。

·export，查看属性值，以类为作用域。

·import，把一个对象的属性值赋值给另一个对象。

·trace，跟踪对象中方法调用，用于程序debug。

·untrace，取消跟踪。

·usingMethods，用于实现方法调用，只能在类定义的方法中使用。这个方法不利于程序的健壮性，所以不建议使用。

接下来，我们使用这些内置的方法。首先定义一个父类User，包括name和level两个属性，addLevel和addHighLevel两个功能方法，initialize构造方法。

> User<-setRefClass（"User"， # 类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<-setRefClass（"Member"，contains="User"， # 子类Member
+ fields=list（age='numeric'）， # 子类中的属性
+ methods=list（
+ addLevel = function（x） { # 覆盖父类的同名方法
+ print（'Member：：addLevel'）
+ callSuper（x） # 调用父类的同名方法
+ level <<- level+1
+ }
+ ）
+）

分别实例化对象u1和m1。

> u1<-User$new（name='u1'，level=10） # 实例化u1
[1] "User：：initialize"
> u1 # 查看u1对象，$new（）不能实现赋值的操作
Reference class object of class "User"
Field "name"：
[1] "conan"
Field "level"：
[1] 1
> u1$initFields（name='u1'，level=10） # 通过$initFields（）向属性赋值
Reference class object of class "User"
Field "name"：
[1] "u1"
Field "level"：
[1] 10
> m1<-Member$new（） # 实例化m1
[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<-u1$copy（） # 属性复制到u2
[1] "User：：initialize"
> u1$addLevel（1）；u1 # 执行方法addLevel（），让level加1，u1已改变
[1] "User：：addLevel"
Reference class object of class "User"
Field "name"：
[1] "u1"
Field "level"：
[1] 11
> u2 # u2的level与u1没有引用关系，u2没有变化
Reference class object of class "User"
Field "name"：
[1] "u1"
Field "level"：
[1] 10

使用方法field（），查看并给level属性赋值。

> u1$field（'level'） # 查看level属性值
[1] 11
> u1$field（'level'，1） # 给level赋值为1
> u1$level # 查看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（m1$getRefClass（）） # 通过otype查看类型的不同
[1] "RC"
> otype（m1$getClass（））
[1] "S4"

使用$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（）方法取消跟踪绑定。

> m1$trace（"addLevel"） # 对addLevel（）方法跟踪
Tracing reference method "addLevel" for object from class "Member"
[1] "addLevel"
> m1$addLevel（1） # 调用addLevel（）方法，Tracing m1$addLevel（1）被打印，跟踪生效
Tracing m1$addLevel（1） on entry
[1] "Member：：addLevel"
[1] "User：：addLevel"
> m1$addHighLevel（） # 调用父类的addHighLevel（）方法，Tracing addLevel（2）被打印，
# 跟踪生效
[1] "User：：addHighLevel"
Tracing addLevel（2） on entry
[1] "Member：：addLevel"
[1] "User：：addLevel"
> m1$untrace（"addLevel"） # 取消对addLevel（）方法跟踪
Untracing reference method "addLevel" for object from class "Member"
[1] "addLevel"

使用$export（）方法，以类为作用域查看属性值。

> m1$export（'Member'） # 查看在Member类中的属性
Reference class object of class "Member"
Field "name"：
[1] "m1"
Field "level"：
[1] 105
Field "age"：
[1] 12
> m1$export（'User'） # 查看在User类中的属性，当前作用域不包括age属性。
[1] "User：：initialize"
Reference class object of class "User"
Field "name"：
[1] "m1"
Field "level"：
[1] 105

使用$import（）方法，把一个对象的属性值赋值给另一个对象。

> m2<-Member$new（） # 实例化m2
[1] "User：：initialize"
> m2
Reference class object of class "Member"
Field "name"：
[1] "conan"
Field "level"：
[1] 1
Field "age"：
numeric（0）
> m2$import（m1） # 把m1对象的值赋值给m2对象
> m2
Reference class object of class "Member"
Field "name"：
[1] "m1"
Field "level"：
[1] 105
Field "age"：
[1] 12

2.内置属性

RC对象实例化后，有两个内置属性。

·.self，实例化对象自身。

·.refClassDef，类的定义类型。

> m1$.self # $.self属性
Reference class object of class "Member"
Field "name"：
[1] "m1"
Field "level"：
[1] 105
Field "age"：
[1] 12
> identical（m1$.self，m1） # m1$.self和m1 完全相同
[1] TRUE
> otype（m1$.self） # 查看类型
[1] "RC"
> m1$.refClassDef # $.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"
> identical（m1$.refClassDef，m1$getClass（）） # 与$getClass（）相同
[1] TRUE
> otype（m1$.refClassDef） # 查看类型
[1] "S4"

4.4.6　RC类的辅助函数

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

·new，用于实例化对象。

·help，用于查询类中方法的调用。

·methods，列出类中定义的所有方法。

·fields，列出类中定义的所有属性。

·lock，给属性加锁，实例化对象的属性只允许赋值一次，即赋值变量，不可修改。

·trace，跟踪方法。

·accessors，给属性生成get/set方法。

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

> User<-setRefClass（"User"， # 定义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<-User$new（） # 实例化对象u1
> User$fields（） # 列出User类中的属性
name level
"character" "numeric"
> User$methods（） # 列出User类中的方法
[1] "addHighLevel" "addLevel" "callSuper"
[4] "copy" "export" "field"
[7] "getClass" "getRefClass" "import"
[10] "initFields" "initialize" "show"
[13] "trace" "untrace" "usingMethods"
> User$help（"addLevel"） # 查看User类的方法调用
Call：
$addLevel（x）
> User$help（"show"）
Call：
$show（）

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

> User$accessors（"level"） # 给level属性增加get/set方法
> User$accessors（"name"） # 给name属性增加get/set方法
> 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$trace（'addLevel'） # 跟踪User类的addLevel方法
Tracing reference method "addLevel" for class
"User"
[1] "addLevel"
> u3<-User$new（name='u3'，level=1） # 实例化对象u3
[1] "User：：initialize"
> u3$addLevel（2） # addLevel方法调用，出发跟踪日志 Tracing u3$addLevel（2）
Tracing u3$addLevel（2） on entry
[1] "User：：addLevel"

使用$lock（）函数，把level属性设置为常量。

> User$lock（"level"） # 锁定level属性
> User$lock（） # 查看User类中被锁定的属性
[1] "level"
> u3<-User$new（） # 实例化对象u3，这时level属性已经被赋值一次
[1] "User：：initialize"
> u3
Reference class object of class "User"
Field "name"：
[1] "conan"
Field "level"：
[1] 1
> u3$level=1 # 给level属性，再次赋值出错
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

4.4.7　RC对象系统的使用

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

1.任务一：定义动物的数据结构和发声方法

假设Animal为动物的基类，研究的动物包括猫（cat）、狗（dog）、鸭（duck）。需要定义动物的数据结构，并且分别定义3种动物的发声bark（）方法。结构如图4-8所示。

图4-8　任务一：动物系统数据结构

定义动物的数据结构，包括基类的结构和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$new（） # 创建cat实例
> cat$name
[1] "cat"
> cat$bark（） # cat叫声
[1] "cat is miao miao"
> dog<-Dog$new（） # 创建dog实例，并给dog起名叫Huang
> dog$initFields（name='Huang'）
Reference class object of class "Dog"
Field "name"：
[1] "Huang"
> dog$name
[1] "Huang"
> dog$bark（） # dog叫声
[1] "Huang is wang wang"
> duck<-Duck$new（） # 创建duck实例
> duck$bark（） # duck叫声
[1] "duck is ga ga"

2.任务二：定义动物的体貌特征

动物的体貌特征，包括头、身体、肢、翅等，我在这里只定义肢和翅的特征。3种动物都有肢，cat和dog是四肢，duck是二肢和二翅。结构如图4-9所示。

图4-9　任务二：动物系统体貌特征的数据结构

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

# 定义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<-Cat$new（）；cat # 实例化cat对象，属性limbs为4
Reference class object of class "Cat"
Field "name"：
[1] "cat"
Field "limbs"：
[1] 4
> dog<-Dog$new（） # 实例化dog对象，属性limbs为4
> 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<-Duck$new（）；duck # 实例化duck对象，属性limbs为2，wing为2
Reference class object of class "Duck"
Field "name"：
[1] "duck"
Field "limbs"：
[1] 2
Field "wing"：
[1] 2

3.任务三：定义动物的行动方式

对于猫（cat）、狗（dog）、鸭（duck）来说，它们都可以在陆地上行动，而且还有各自不同的行动方式。特有行动方式：

·猫（cat），爬树

·狗（dog），游泳

·鸭（duck），游泳，短距离飞行

结构如图4-10所示。

图4-10　任务三：动物系统行动方式的数据结构

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

# 定义类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$new（） # 实例化cat
> cat$action（） # cat的行动
[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对象系统提供了完全的面向对象的实现，书中第6章将会基于RC的面向对象程序设计用于游戏框架的开发。

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

问题

如何基于R6面向对象系统编程？

引言

R6是什么？难道是一种新的类型吗？其实，我也是在无意中发现R6的。R6是R语言的一个面向对象的R包，R6类型非常接近于RC类型，但比RC类型更轻，由于R6不依赖于S4的对象系统，所以用R6构建面向对象系统会更加有效率。

4.5.1　初识R6

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

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

4.5.2　创建R6类和实例化对象

本节的系统环境是：

·Windows 7 64bit

·R：3.1.1 x86_64-w64-mingw32/x64（64-bit）

我们先安装R6包，同时为了方便我们检查对象的类型，引入pryr包作为辅助工具。关于pryr包的介绍，请参看3.1节。

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

注　R6同时支持Windows 7环境和Linux环境。

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.创建R6的类和实例化对象

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

> Person <- R6Class（"Person"， # 定义一个R6类
+ public=list（
+ hello = function（）{ # 定义公有方法hello
+ print（paste（"Hello"））
+ }
+ ）
+）
> Person # 查看Person的定义
<Person> object generator
Public：
hello： function
Parent env： <environment： R_GlobalEnv>
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在传值和继承上会更有效率。

3.公有成员和私有成员

类的成员，包括属性和方法两部分。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包开发上的技巧。

4.5.3　R6类的主动绑定

主动绑定（active binding）是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.5.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（）方法，从输出可以看出，父类的同名方法也同时被调用了。

4.5.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类的实例化对象b对A类的实例化对象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对象，是对单独的环境空间中的引用，所以不能实现引用对象的共享。

4.5.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对象的使用。

4.5.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对象进行访问。

4.5.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

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

4.5.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的面向对象编程。

4.5.10　R6面向对象系统的案例

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

1.任务一：定义图书的静态结构

以图书（book）为父类，包括R，Java，PHP的3个分类，在book类中定义私有属性及公有方法，继承关系如图4-11所示。

图4-11　任务一：图书数据结构

定义图书系统的数据结构，包括父类的结构和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

2.任务二：正逢双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语言的面向对象体系结构，选择自己理解的，总有一种会适合你。

第三部分　开发自己的R包

■第5章　R包开发

■第6章　R语言游戏之旅

第5章　R包开发

本章介绍R包开发的方法。通过底层R语言函数从头构建R包是复杂的，用devtools包就可以帮助我们简化开发流程。通过每日中国天气应用的R包开发实例，帮助读者全面了解R包开发的过程。

5.1　从头开发自己的R包

问题

如何开发一个R包？

引言

R是一个世界范围开发者共同协作的产物，至2014年9月共计近5887个包可在互联网上自由下载。现在我们作为R语言的使用者，有朝一日也可以成为R语言的开发者，把我们自己的知识做成R语言工具包分享给世界。本节我们将学习如何开发一个自己的R包。

5.1.1　用Linux命令行开发R包

让我们从零开始创建一个R包，仅通过Linux命令行就可以完成全部的操作。我们将按照创建R项目、打包R项目、安装R包、使用R包、检查R包、卸载R包6个步骤介绍R包的开发。开发R包到底有多难，只有你试了才知道。

本节的系统环境是：

·Linux：Ubuntu Server 12.04.2 LTS 64bit

·R：3.1.1 x86_64-pc-linux-gnu（64-bit）

注　R包开发同时支持Windows 7环境和Linux环境，为了减少发布时的错误，建议选择Linux环境开发，本书6.5节介绍在Windows 7中开发R包。

1.创建sayHello项目

创建一个R包，要如何开始呢？第一步，先给项目起个名字，比如sayHello，然后创建项目工作目录/home/conan/R/demo。

~ mkdir /home/conan/R/demo # 创建目录~ cd /home/conan/R/demo # 进入目录

第二步，在项目中新建R文件sayHello.R，自定义一个sayHello的函数，作为自定义包的第一个函数。

~ vi sayHello.R # 新建 sayHello.R
sayHello<-function（name）{
print（paste（"Hello"，name））
}

第三步，用系统的原生的package.skeleton（）函数，生成sayHello项目的骨架。

~ R # 启动R程序
> rm（list=ls（）） # 清空变量设置工作目录
> setwd（"/home/conan/R/demo"） # 设置项目目录
> package.skeleton（name="sayHello"，code_files="/home/conan/R/demo/sayHello.R"）
# 通过sayHello的脚本生成项目骨架
Creating directories ...
Creating DESCRIPTION ...
Creating NAMESPACE ...
Creating Read-and-delete-me ...
Copying code files ...
Making help files ...
Done.
Further steps are described in './sayHello/Read-and-delete-me'.

我们看到在当前目录生成一个sayHello目录。

~ ls -l # 查看当前目录
drwxrwxr-x 4 conan conan 4096 9月 28 09：57 sayHello
-rw-rw-r-- 1 conan conan 59 9月 28 09：48 sayHello.R~ ls -l sayHello # 查看sayHello目录
-rw-rw-r-- 1 conan conan 281 9月 28 09：57 DESCRIPTION
drwxrwxr-x 2 conan conan 4096 9月 28 09：57 man
-rw-rw-r-- 1 conan conan 31 9月 28 09：57 NAMESPACE
drwxrwxr-x 2 conan conan 4096 9月 28 09：57 R
-rw-rw-r-- 1 conan conan 420 9月 28 09：57 Read-and-delete-me~ ls -l sayHello/man # 查看man目录
-rw-rw-r-- 1 conan conan 1043 9月 28 09：57 sayHello-package.Rd
-rw-rw-r-- 1 conan conan 1278 9月 28 09：57 sayHello.Rd~ ls -l sayHello/R # 查看R目录
-rw-rw-r-- 1 conan conan 59 9月 28 09：57 sayHello.R

文件及目录解释：

·DESCRIPTION文件：项目描述文件，用于设置项目的全局的配置。

·NAMESPACE文件：项目命名空间，用于设置项目输入输出函数。

·Read-and-delete-me文件：说明文件，可以删除。

·man目录：存放函数的帮助文件的目录。

·R目录：存放源代码文件的目录。

·man/sayHello.Rd：sayHello函数的帮助文件，LaTex语法，用来生成PDF文档。

·man/sayHello-package.Rd：sayHello包的帮助文件，可以删除。

第四步，让我们来编辑DESCRIPTION文件，定义项目全局的配置。

~ vi sayHello/DESCRIPTION
Package： sayHello
Type： Package
Title： R package demo for sayHello
Version： 1.0
Date： 2014-09-28
Author： Dan Zhang
Maintainer： Dan Zhang <bsspirit@gmail.com>
Description： This package provides a package demo
License： GPL-3

其中Package是项目名（包名）；Type是项目类型；Title是项目标题；Version是项目版本号；Date是项目创建日期；Author是项目作者；Maintainer是主要贡献者，可以多人；Description是项目详细描述，建议多点的文字；License是项目的发布协议。

通过编写DESCRIPTION文件，我们其实就定义了整个项目的配置信息。

第五步，编辑NAMESPACE文件，用于设置项目中函数输入和输出。

~ vi sayHello/NAMESPACE
export（sayHello）

我们项目里只有一个函数sayHello，而且这个函数是对使用者开放的，那么只要一行定义就行了。

第六步，编辑sayHello.Rd文件，编写sayHello函数的帮助文档，这里用到LaTex的语法。

~ vi sayHello/man/sayHello.Rd
\name{sayHello}
\alias{sayHello}
\title{a sayHello function demo}
\description{
a sayHello function demo
}
\usage{
sayHello（name）
}
\arguments{
\item{name}{a word}
}
\details{
nothing
}
\value{
no return
}
\references{
nothing
}
\author{
Dan Zhang
}
\note{
nothing
}
\seealso{
nothing
}
\examples{
sayHello（"world"）
}
\keyword{ sayHello }

第七步，删除可忽略的文件。如果不删除的话，check过程会出现警告。

~ rm sayHello/Read-and-delete-me~ rm sayHello/man/sayHello-package.Rd

通过上面的7个步骤，我们就完成了新建sayHello的R包的任务。

2.对sayHello项目进行打包。

创建好了一个R包项目，接下来，我们需要对这个项目进行打包，生成R包安装文件。通过命令安装这个文件，加载到用户环境，就可以像其他包一样使用我们自己创建的R包了。

我们切换到命令行，执行打包的命令。

~ R CMD build sayHello # 执行打包命令
* checking for file 'sayHello/DESCRIPTION' ... OK
* preparing 'sayHello'：
* checking DESCRIPTION meta-information ... OK
* checking for LF line-endings in source and make files
* checking for empty or unneeded directories
* building 'sayHello_1.0.tar.gz'

打包顺利完成，在当前目录下生成了sayHello项目的安装包sayHello_1.0.tar.gz。

~ ls -l # 查看当前目录文件
drwxrwxr-x 4 conan conan 4096 9月 28 10：34 sayHello
-rw-r--r-- 1 conan conan 622 9月 28 11：01 sayHello_1.0.tar.gz
-rw-rw-r-- 1 conan conan 59 9月 28 09：48 sayHello.R

3.本地安装sayHello包

在本地环境中安装sayHello包，一切正常。

~ R CMD INSTALL sayHello_1.0.tar.gz # 通过命令行安装sayHello_1.0.tar.gz
* installing to library '/home/conan/R/x86_64-pc-linux-gnu-library/3.1'
* installing *source* package 'sayHello' ...
** R
** preparing package for lazy loading
** help
*** installing help indices
** building package indices
** testing if installed package can be loaded
* DONE （sayHello）

查看R的安装目录，找到sayHello目录。

~ ls /home/conan/R/x86_64-pc-linux-gnu-library/3.1
bitops devtools evaluate memoise RCurl sayHello

4.使用sayHello包中的函数

启动R程序，加载sayHello包，并执行sayHello包的函数。

~ R # 启动R程序
> library（sayHello） # 加载sayHello包
> sayHello（"Conan"） # 执行包中的函数
[1] "Hello Conan"
> sayHello #查看sayHello函数系统帮助文档
sayHello package：sayHello R Documentation
a sayHello function demo
Description：
a sayHello function demo
Usage：
sayHello（name）
Arguments：
name： a word
Details：
nothing
Value：
no return
Note：
nothing
Author（s）：
Dan Zhang
References：
nothing
See Also：
nothing
Examples：
sayHello（"world"）

这样，我们的包已经成功制作完成，并成功地在本地进行安装和使用！

5.检查R包

如果要想发布R包到CRAN，我们的工作还远远没有完成。R包在提交前，必须要执行check检查，任何的error和warning都将导致不能通过。check检查是开发过程中最麻烦的一步，几乎做不到一次就通过，所以大家要耐心解决各种错误。

再切回到命令行，在执行check检查的过程中会生成PDF，而生成PDF又会依赖于LaTex，所以要先安装LaTex的依赖包（500MB+）。

~ sudo apt-get install texlive-full # 安装LaTex

LaTex安装完成，再执行check命令。

~ R CMD check sayHello_1.0.tar.gz # 执行check检查
* using log directory '/home/conan/R/demo/sayHello.Rcheck'
* using R version 3.1.1 （2014-07-10）
* using platform： x86_64-pc-linux-gnu （64-bit）
* using session charset： UTF-8
* checking for file 'sayHello/DESCRIPTION' ... OK
* checking extension type ... Package
* this is package 'sayHello' version '1.0'
* checking package namespace information ... OK
* checking package dependencies ... OK
* checking if this is a source package ... OK
* checking if there is a namespace ... OK
* checking for executable files ... OK
* checking for hidden files and directories ... OK
* checking for portable file names ... OK
* checking for sufficient/correct file permissions ... OK
* checking whether package 'sayHello' can be installed ... OK
* checking installed package size ... OK
* checking package directory ... OK
* checking DESCRIPTION meta-information ... OK
* checking top-level files ... OK
* checking for left-over files ... OK
* checking index information ... OK
* checking package subdirectories ... OK
* checking R files for non-ASCII characters ... OK
* checking R files for syntax errors ... OK
* checking whether the package can be loaded ... OK
* checking whether the package can be loaded with stated dependencies ... OK
* checking whether the package can be unloaded cleanly ... OK
* checking whether the namespace can be loaded with stated dependencies ... OK
* checking whether the namespace can be unloaded cleanly ... OK
* checking loading without being on the library search path ... OK
* checking dependencies in R code ... OK
* checking S3 generic/method consistency ... OK
* checking replacement functions ... OK
* checking foreign function calls ... OK
* checking R code for possible problems ... OK
* checking Rd files ... OK
* checking Rd metadata ... OK
* checking Rd cross-references ... OK
* checking for missing documentation entries ... OK
* checking for code/documentation mismatches ... OK
* checking Rd \usage sections ... OK
* checking Rd contents ... OK
* checking for unstated dependencies in examples ... OK
* checking examples ... OK
* checking PDF version of manual ... OK

通过了check检查的R包，就可以申请提交到CRAN了。虽然这个sayHello例子比较简单，但也不是说check过程就一帆风顺，可能会出现各种莫名其妙的警告和错误。我也是修正了很多的小问题，才能顺利通过check的检查。

6.卸载R包

我们安装了R包，有时候也需要卸载，特别是处于开发状态的R包。卸载R包其实比较简单，可以通过两种方式，一种是命令行卸载，一种是函数卸载。

命令行卸载，执行如下命令操作。

~ R CMD REMOVE sayHello # 卸载R包
Removing from library '/home/conan/R/x86_64-pc-linux-gnu-library/3.1'~ ls /home/conan/R/x86_64-pc-linux-gnu-library/3.1 # 查看R包的安装目录
bitops devtools evaluate memoise RCurl

函数卸载，在R语言的环境中用remove.packages（）函数来实现。

> remove.packages（"sayHello"） # 卸载R包
Removing package from '/home/conan/R/x86_64-pc-linux-gnu-library/3.1'（as 'lib' is unspecified）
> library（sayHello） # 无法加载sayHello包
Error in library（sayHello） ： there is no package called 'sayHello'

5.1.2　RStudio中开发R包

上面的操作都是在Linux命令行通过vi编辑器配合完成的，对Linux命令和vi不熟的人会觉得难度比较大。我们还可以通过在RStudio中完成R包的开发，把Linux的RStudio Server的环境配置好，这在《R的极客理想——工具篇》的1.5节已经介绍过。RStudio已经为我们准备了一个有界面的编程环境，可以更方便我们制作R包。

1.RStudio中开发R包

我们把上文在命令行操作的过程，用RStudio重新操作一遍。首先，在RStudio中创建一个新项目，包名为sayHello2，类型为Package，源文件包括sayHello.R，如图5-1所示。

图5-1　通过RStudio创建项目

RStudio会自动调用package.skeleton（）函数生成的项目文件，当然这些文件也可以自己手动去建，如图5-2所示。

图5-2　RStudio项目文件目录

2.编辑项目描述文件DESCRIPTION和NAMESPACE

这里包名为sayHello2，其他配置一样，解释同命令行操作。

如下编辑DESCRIPTION文件：

Package： sayHello2
Type： Package
Title： R package demo for sayHello
Version： 1.0
Date： 2014-09-28
Author： Dan Zhang
Maintainer： Dan Zhang <bsspirit@gmail.com>
Description： This package provides a package demo
License： GPL-3

编辑NAMESPACE文件：

export（sayHello）

3.编辑R程序代码R/sayHello.R

创建sayHello.R文件，定义sayHello函数。

~ vi sayHello.R
sayHello<-function（name）{
print（paste（"Hello"，name））
}

4.编辑帮助文档man/sayHello.Rd

同命令行的文档。

\name{sayHello}
\alias{sayHello}
\title{a sayHello function demo}
\description{
a sayHello function demo
}
\usage{
sayHello（name）
}
\arguments{
\item{name}{a word}
}
\details{
nothing
}
\value{
no return
}
\references{
nothing
}
\author{
Dan Zhang
}
\note{
nothing
}
\seealso{
nothing
}
\examples{
sayHello（"world"）
}
\keyword{ sayHello }

5.执行build和reload

点击RStudio的Build菜单中的Build&Reload按钮，执行build和reload过程，如图5-3所示。

图5-3　通过RStudio运行Build&Reload

我们会看到有2个警告是关于sayHello2-package.Rd文件的，删除与打包无关的2个文件，man/sayHello2-package.Rd和Read-and-delete-me。再次运行Build&Reload警告就没有了，从日志中看到，sayHello2同时被安装到了R语言环境中，如图5-4所示。

图5-4　通过RStudio再次运行Build&Reload

下面就更简单了，在Console运行环境中，加载sayHello包，并执行sayHello（）函数，如图5-5所示。

> library（sayHello2）
> sayHello（'Conan'）
[1] "Hello Conan"
> sayHello
> sayHello
function （name）
{
print（paste（"Hello"， name））
}
<environment： namespace：sayHello2>

图5-5　加载sayHello包，并执行函数

6.执行check

最后我们再测试check操作，在RStudio中点击check按钮执行check的操作，所图5-6所示。

图5-6　通过RStudio完成check操作

我们一路顺畅地完成了R包开发的操作，基本就是点点鼠标。在RStudio中进行R的开发、打包、检查等过程非常方便，RStudio简直就是R语言开发的神器。

本节中按照R语言开发规范介绍了完整的R包开发过程，虽然规范中每一步过程都很清楚，但是操作过于复杂，官方函数支持明显不够，给R包的开发带来了很多的困难。下一节介绍的由Hadley Wickham重新定义的开发流程，可以帮助我们更简单地完整R包开发的工作。

5.2　标准化R包开发流程

问题

有没有简单的R包开发的方法？

引言

在上一节我们看到了如何从底层按照R语言的标准构建一个R语言的扩展包，但实施过程确实复杂，会让很多没有编程背景的R语言用户望而却步。如果能有一种比较简单的方式简化开发过程，那该多好啊！我们是幸运的，Hadley Wickham重新梳理出了一套R包开发流程，并提供了多种辅助函数让R包开发更简单。站在巨人的肩膀上，我们会看得更高，走得更远。

5.2.1　开发流程介绍

站在巨人的肩膀再来开发R包，就有3个武器，即devtools、roxygen2和testthat。

·devtools：各种开发小工具的合集，让开发变得简单，非常实用。

·roxygen2：通过注释的方式，生成文档，远离LaTex的烦恼。

·testthat：单元测试，让R包稳定、健壮，减少升级的痛苦。

重新标准化的开发流程，按下面5个步骤来实施：编写功能代码、调试程序、单元测试、撰写文档、程序打包。

5.2.2　编写功能代码

接下来，我们整个的开发过程，还是完全通过Linux命令和vi编辑器配合来完成，对于需要界面编程的用户，可以参考5.1节中的在RStudio环境中开发R包的过程。

本节的系统环境是：

·Linux：Ubuntu Server 12.04.2 LTS 64bit

·R：3.1.1 x86_64-pc-linux-gnu（64-bit）

注　R包开发同时支持Windows 7环境和Linux环境，为了减少发布时的错误，建议选择Linux上开发。

1.安装程序包：devtools，roxygen2，testthat

在安装这3个R包之前，需要先安装系统的依赖软件包，比如libcurl4-openssl-dev。

~ sudo apt-get install libcurl4-openssl-dev

启动R程序，安装R包的开发工具包devtools，roxygen2，testthat。

~ R # 启动R程序
> install.packages（"devtools"） # 安装程序包
> install.packages（"roxygen2"）
> install.packages（"testthat"）
> library（devtools） # 加载程序包
> library（roxygen2）
> library（testthat）
> search（） # 查看当前环境中的程序包
[1] ".GlobalEnv" "package：testthat" "package：roxygen2"
[4] "package：devtools" "package：stats" "package：graphics"
[7] "package：grDevices" "package：utils" "package：datasets"
[10] "package：methods" "Autoloads" "package：base"

2.创建项目chinaWeather

新建一个项目，命名为chinaWeather。创建骨架用devtools包的create（）函数代替原生package.skeleton（）函数。

> setwd（"/home/conan/R"） # 设置工作目录
> create（"/home/conan/R/chinaWeather"） # 创建项目
Creating package chinaWeather in /home/conan/R
No DESCRIPTION found. Creating with values：
Package： chinaWeather
Title： What the package does （one line）
Version： 0.1
Authors@R： "First Last <first.last@example.com> [aut， cre]"
Description： What the package does （one paragraph）
Depends： R （>= 3.1.1）
License： What license is it under
LazyData： true
Adding RStudio project file to chinaWeather

检查创建的目录和文件。

> setwd（"/home/conan/R/chinaWeather"） # 设置项目目录
> dir（） # 查看目录中的文件
[1] "DESCRIPTION" "NAMESPACE" "R"

3.创建项目文件

编辑文件DESCRIPTION。

~ vi /home/conan/R/chinaWeather/DESCRIPTION
Package： chinaWeather
Type： Package
Title：a visualized package for china Weather
Version： 0.1
Authors@R： "Dan Zhang <bsspirit@gmail.com> [aut， cre]"
Description： a visualized package for china Weather
Depends： R （>= 3.1.1）
License： GPL-2
LazyData： true
Date： 2014-09-28

新建R程序文件chinaWeather.R，在文件中定义函数filename（），注释不能包括中文。

~ vi /home/conan/R/chinaWeather/R/chinaWeather.R
# define a filename from current date
filename<-function（date=Sys.time（））{
paste（format（date， "%Y%m%d"），".csv"，sep=""）
}

这里我们定义了一个简单的函数filename（），根据日期生成一个文件名。

5.2.3　调试程序

在devtools包的帮助下，开发过程中可以直接加载项目目录到R的运行时环境中，而不用像之前那样，每次打包后才能加载运行。

> load_all（"/home/conan/R/chinaWeather"） # 加载项目目录
Loading chinaWeather
> filename # 查看filename（）函数
function（date=Sys.time（））{
paste（format（date， "%Y%m%d"），".csv"，sep=""）
}
<environment： namespace：chinaWeather>
> filename（） # 运行filename（）函数
[1] "20140928.csv"
> day<-as.Date（"20110701"，format="%Y%m%d"） # 传参并运行filename（）函数
> filename（day）
[1] "20110701.csv"

5.2.4　单元测试

对于软件项目来说，为保持项目代码的健壮性，通常要求编写单元测试的代码。那么对于filename（）这个函数如何进行单元测试呢？

创建用于单元测试的目录。

~ mkdir -p /home/conan/R/chinaWeather/inst/tests # 创建tests目录，用于存放单元测试的文件

新建文件test.chinaWeather.R，用来实现对chinaWeather.R文件中函数的单元测试。我们需要注意，单元测试文件的命名以test.开头，加上源代码文件的文件名。

新建文件test.chinaWeather.R，用test_that（）函数定义单元测试的代码。

~ vi /home/conan/R/chinaWeather/inst/tests/test.chinaWeather.R
library（testthat）
context（"filename： current of date"）
test_that（"filename is current of date"， {
daystr<-paste（format（Sys.Date（）， "%Y%m%d"），".csv"，sep=""）
expect_that（filename（）， equals（daystr））
day<-as.Date（"20110701"，format="%Y%m%d"）
expect_that（filename（day）， equals（"20110701.csv"））
}）

运行单元测试程序。

> source（"/home/conan/R/chinaWeather/inst/tests/test.chinaWeather.R"）
# 加载单元测试程序
> test_file（"/home/conan/R/chinaWeather/inst/tests/test.chinaWeather.R"）
# 执行单元测试
filename： current of date ： ..
> test_dir（"/home/conan/R/chinaWeather/inst/tests/"，reporter = "summary"）
# 对目录下所有文件的单元测试
filename： current of date ： ..

如果单元测试结果是正确的，则没有特别的显示输出。我们增加一个错误的case，看看输出会有什么不一样的地方。修改test.chinaWeather.R文件，增加下面的代码。

~ vi /home/conan/R/chinaWeather/inst/tests/test.chinaWeather.R
library（testthat）
context（"filename： current of date"）
test_that（"filename is current of date"， {
daystr<-paste（format（Sys.Date（）， "%Y%m%d"），".csv"，sep=""）
expect_that（filename（）， equals（daystr））
day<-as.Date（"20110701"，format="%Y%m%d"）
expect_that（filename（day）， equals（"20110701.csv"））
}）
test_that（"filename is current of date， bad test"， {
day<-as.Date（"20110701"，format="%Y%m%d"）
expect_that（filename（day）， equals（"20110702.csv"））
}）

再次启动单元测试程序，则出现错误提示。

> source（"/home/conan/R/chinaWeather/inst/tests/test.chinaWeather.R"）
Error： Test failed： 'filename is current of date， bad test'
Not expected： filename（day） not equal to "20110702.csv"
1 string mismatches：
x[1]： "20110702.csv"
y[1]： "20110701.csv"
> test_file（"/home/conan/R/chinaWeather/inst/tests/test.chinaWeather.R"）
filename： current of date ： ..1
1. Failure（@test.chinaWeather.R#14）： filename is current of date， bad test -----
filename（day） not equal to "20110702.csv"
1 string mismatches：
x[1]： "20110702.csv"
y[1]： "20110701.csv"

我们去掉错误的单元测试代码，继续下面的操作。如果这个包的功能函数很多，测试代码也会很多，那么我们可能需要对程序包进行自动化测试，通过设置源代码目录和测试代码目录，调用auto_test（）函数会扫描两个目录下的所有文件。

自动化单元测试代码配置。

> src<-"/home/conan/R/chinaWeather/R/" # 源代码目录
> test<-"/home/conan/R/chinaWeather/inst/tests/" # 单元测试代码目录
> auto_test（src，test） # 执行单元测试
filename： current of date ： ..

另外，我们也可以对整个包执行单元测试，因为源文件目录和测试文件目录，在同一个项目的位置是固定的。

> test（"/home/conan/R/chinaWeather"）
Testing chinaWeather
filename： current of date ： ..

这样我们就非常顺利地完成了单元测试，下面就要开始撰写帮助文档了。

5.2.5　撰写文档

上一节中介绍，我们不仅要动手编写基于LaTex格式的帮助文档，而且文档和代码是分离在不同文件的，所以写文档的难度很高。本节中用到roxygen2包的撰写文档，通过源代码注释的方式，生成LaTex格式的帮助文档，这种方式更贴近于程序员的思路，而且写注释比写LaTex要容易得多。

编辑源代码文件：chinaWeather.R，给函数增加注释。

~ vi /home/conan/R/chinaWeather/R/chinaWeather.R # 编辑文件
#' Define a filename from current date.
#'
#' @param date input a date type
#' @return character a file name
#' @keywords filename
#' @export
#' @examples
#' filename（）
#' filename（as.Date（"20110701"，format="%Y%m%d"））
filename<-function（date=Sys.time（））{
paste（format（date， "%Y%m%d"），".csv"，sep=""）
}

然后通过roxygen2包的roxygenize（）函数，生成LaTex帮助文档。

> roxygenize（"/home/conan/R/chinaWeather"） # 用roxygenize（）函数，生成latex文档
First time using roxygen2 4.0. Upgrading automatically...
Writing NAMESPACE
Writing filename.Rd

查看生成的LaTex文件。

~ cat /home/conan/R/chinaWeather/man/filename.Rd # 查看说明帮助文档文件
% Generated by roxygen2 （4.0.2）： do not edit by hand
\name{filename}
\alias{filename}
\title{Define a filename from current date.}
\usage{
filename（date = Sys.time（））
}
\arguments{
\item{date}{input a date type}
}
\value{
character a file name
}
\description{
Define a filename from current date.
}
\examples{
filename（）
filename（as.Date（"20110701"，format="\%Y\%m\%d"））
}
\keyword{filename}

虽然注释方式与原来的方式相差不大，但是规避了LaTex的语法，终于能让我们能专心写R包了。

5.2.6　程序打包

上面的程序过程（项目加载、单元测试、生成帮助文档）还可以更简单一些，只需要3个函数调用。

> load_all（"/home/conan/R/chinaWeather"） # 加载项目目录
> test（"/home/conan/R/chinaWeather"） # 执行单元测试
> document（"/home/conan/R/chinaWeather"） # 生成文档文件

执行程序检查，也是一个函数调用就可以完成的。

> check（"/home/conan/R/chinaWeather"） # 执行程序检查
Updating chinaWeather documentation
Loading chinaWeather
'/usr/lib/R/bin/R' --vanilla CMD build '/home/conan/R/chinaWeather' \
--no-manual --no-resave-data
* checking for file '/home/conan/R/chinaWeather/DESCRIPTION' ... OK
* preparing 'chinaWeather'：
* checking DESCRIPTION meta-information ... OK
* checking for LF line-endings in source and make files
* checking for empty or unneeded directories
* building 'chinaWeather_0.1.tar.gz'
'/usr/lib/R/bin/R' --vanilla CMD check \
'/tmp/RtmpJ37lsJ/chinaWeather_0.1.tar.gz' --timings
* using log directory '/tmp/RtmpJ37lsJ/chinaWeather.Rcheck'
* using R version 3.1.1 （2014-07-10）
* using platform： x86_64-pc-linux-gnu （64-bit）
* using session charset： UTF-8
* checking for file 'chinaWeather/DESCRIPTION' ... OK
* checking extension type ... Package
* this is package 'chinaWeather' version '0.1'
* checking package namespace information ... OK
* checking package dependencies ... OK
* checking if this is a source package ... OK
* checking if there is a namespace ... OK
* checking for executable files ... OK
* checking for hidden files and directories ... OK
* checking for portable file names ... OK
* checking for sufficient/correct file permissions ... OK
* checking whether package 'chinaWeather' can be installed ... OK
* checking installed package size ... OK
* checking package directory ... OK
* checking DESCRIPTION meta-information ... OK
* checking top-level files ... OK
* checking for left-over files ... OK
* checking index information ... OK
* checking package subdirectories ... OK
* checking R files for non-ASCII characters ... OK
* checking R files for syntax errors ... OK
* checking whether the package can be loaded ... OK
* checking whether the package can be loaded with stated dependencies ... OK
* checking whether the package can be unloaded cleanly ... OK
* checking whether the namespace can be loaded with stated dependencies ... OK
* checking whether the namespace can be unloaded cleanly ... OK
* checking loading without being on the library search path ... OK
* checking dependencies in R code ... OK
* checking S3 generic/method consistency ... OK
* checking replacement functions ... OK
* checking foreign function calls ... OK
* checking R code for possible problems ... OK
* checking Rd files ... OK
* checking Rd metadata ... OK
* checking Rd line widths ... OK
* checking Rd cross-references ... OK
* checking for missing documentation entries ... OK
* checking for code/documentation mismatches ... OK
* checking Rd \usage sections ... OK
* checking Rd contents ... OK
* checking for unstated dependencies in examples ... OK
* checking examples ... OK
* checking PDF version of manual ... OK

一切顺利，全部通过查检。

5.2.7　程序发布

开发完的R包，如果愿意开源给其他人使用，有几个发布平台供选择：CRAN、RForge和Github。

·CRAN是大家都比较熟悉的，由R Core的小组维护，审查很严格。

·RForge是另一个R项目的发布平台。

·Github是通过devtools包维护的一个发布平台，适合个人发布，无审查。

由于CRAN和RForge平台有各种审查，不允许随便发布，那么我们就先把程序发布到Github上面吧，等功能完善后，再申请提交到CRAN或RForge。把项目上传到Github的操作，和R语言就没什么关系了。我们需要先在本地安装git工具，然后在Github社区创建一个资源库，通过git工具实现项目的上传。我在Github创建一个新的资源库chinaWeatherDemo，项目地址为https://github.com/bsspirit/chinaWeatherDemo，如图5-7所示。

下面提交本地代码到Github。

~ cd /home/conan/R/chinaWeather # 进入项目目录~ git init # 初始化git项目
Initialized empty Git repository in /home/conan/R/chinaWeather/.git/~ git add . # 用git管理本地文件~ git commit -m 'init' # 用git提交文件到本地库
[master （root-commit） 43deae4] init
6 files changed， 62 insertions（+）
create mode 100644 .gitignore
create mode 100644 DESCRIPTION
create mode 100644 NAMESPACE
create mode 100644 R/chinaWeather.R
create mode 100644 inst/tests/test.chinaWeather.R
create mode 100644 man/filename.Rd~ git remote add origin https：//github.com/bsspirit/chinaWeather
# 绑定本地库和github的远程库~ git push -u origin master # 把本地库同步远程库
To https：//github.com/bsspirit/chinaWeatherDemo.git
* [new branch] master -> master
Branch master set up to track remote branch master from origin.

图5-7　在Github上创建新项目

这样代码就上传到了Github，接下来，通过devtools包可以非常方便地把R语言项目从Github下载并安装。

现在我的chinaWeather包，已经在Github上面发布了，如果其他同学想使用，可以按照下面的命令来安装。

> library（devtools） # 加载devtools
> install_github（"bsspirit/chinaWeatherDemo"） # 下载并安装chinaWeather包
Downloading github repo bsspirit/chinaWeatherDemo@master
Installing chinaWeather
'/usr/lib/R/bin/R' --vanilla CMD INSTALL \
'/tmp/RtmpJ37lsJ/devtools646348c59273/bsspirit-chinaWeatherDemo-43deae4' \
--library='/home/conan/R/x86_64-pc-linux-gnu-library/3.1' --install-tests
* installing *source* package 'chinaWeather' ...
** R
** inst
** preparing package for lazy loading
** help
*** installing help indices
** building package indices
** testing if installed package can be loaded
* DONE （chinaWeather）
Reloading installed chinaWeather
> library（chinaWeather） # 加载chinaWeather包
> filename（） # 运行filename（）函数
[1] "20140928.csv"
> filename # 查看帮助文档
filename package：chinaWeather R Documentation
Define a filename from current date.
Description：
Define a filename from current date.
Usage：
filename（date = Sys.time（））
Arguments：
date： input a date type
Value：
character a file name
Examples：
filename（）
filename（as.Date（"20110701"，format="%Y%m%d"））

我们已经完成了开发R包的全部流程，依赖于devtools、roxygen2和testthat三个工具包，真是事半功倍，比起完全手动操作高效很多！希望更多的朋友，可以站在巨人的肩膀前行，创造让人惊叹的成果！

5.3　R语言天气可视化应用

问题

如何用R语言做一个天气可视化的应用？

引言

在很多人看来，R语言还只是个玩具，完全不具备企业级应用的能力。说这些话的人，可能根本就不了解R语言，更不清楚如何做企业级应用开发。从我最早接触R语言时，就把R作为可视化引擎嵌入到了晒粉丝的微博应用中；后来又开发了数据挖掘算法竞赛网站，并把R语言做为算法引擎，支持在线编程及运行；我做的第三个R语言应用就是本节要给大家分享的每日中国天气微博应用，这次同样是把R作为可视化引擎，并让R完成爬虫、XML文档解析及数据处理等任务；当然，我还实现了第四个、第五个、第六个以R为核心的应用，都是量化投资方面的，会在下一本书《R的极客理想——量化投资篇》再介绍给大家。

从我的使用经验来看，R语言已经具备了企业级应用的能力，但我并不是要用R语言完成所有编程任务。在我的项目环境中，大都是多种编程语言配合使用的，只有发挥各自语言的特性优势，才是未来的发展方向。

每日中国天气微博应用开发，将分为2节内容进行介绍，5.3节是R语言功能实现，5.4节是R包开发。

5.3.1　项目介绍

多语言混编，如同在计算机领域跨学科一样，是我一直所倡导的一种工作模式。如今编程语言百花齐放，各种细分市场的小众语言如雨后春笋般地成长起来，比起通用型编程语言来说，这些小众语言在特定的领域中有着非常明显的优势。比如统计应用，如果用Java写个逻辑回归程序感觉深不见底，而用R语言实现逻辑回归就是很平常的一件事情。再比如做一个Web网站，用PHP或Node.js实现轻而易举，如果用Java做不仅代码量大，而且程序复杂。所以，对于一个应用来说，一种通用的语言并不一定是最好的解决方案，如果能实现多种语言的结合，那么你做出来的应用可以很酷，很不一样！

对于本节要介绍的“每日中国天气”这个新浪微博应用，就是一种多语言混编的实现。

这个项目的出发点很简单，就是通过可视化技术，展示中国每个省份的天气情况，给准备旅游的朋友，提供一种出行的提示。要实现这个应用，我们首先要列出需要实现哪些功能、会遇到哪些问题等。

·天气数据：数据从哪里找到，如何下载，如何存储。

·定时任务：天气数据需要每日更新，图片需要每日新生成。

·地图和天气可视化：要把中国行政区图和天气数据结合在一起画图，让用户一眼就能看明白。

·Web展示：通过可视化技术生成静态图片，然后发布到Web端进行展示。

·微博：通过结合新浪微博，让更多的用户看到并使用这个应用。

·用户交互：用户可以查看不同日期、不同类型的图片，用户还可以通过微博分享。

虽然是个很小的应用，但麻雀虽小五脏俱全，我们也需要完整地思考如何才能实现这个应用。

5.3.2　系统架构设计

从上面的功能描述中可以看出，单独使用一种语言也可以开发。如果单独用PHP开发，做一个Web网站非常容易，连接新浪微博也有现成的SDK可以调用，爬取数据及存储也不麻烦，那么如何实现地图和天气数据的可视化，似乎就很困难了。如果单独用R开发，爬取数据及存储同样很容易实现，地图和天气数据的可视化也是很方便就能画出来，但是用R做Web网站，那就会遇到很大的瓶颈了，因为R是单线程同步的计算模型，Web应用的高并发特点，会直接让R程序崩溃的。所以，综合上面的问题，如果R语言和PHP语言能结合在一起使用，不仅能避开每种语言不擅长的地方，还能让每种语言在擅长的领域发挥优势，我们将通过多语言的混编技术做出很不一样的应用来。

为了实现应用的功能需求，我们要设计一套系统架构，如图5-8所示。

图5-8　简单系统架构

上面的系统架构解释如下：

·通过定时器启动爬虫程序，到Yahoo的天气数据源下载数据。

·爬虫下载数据到本地服务器进行解析，存储应用相关的数据到CSV文件。

·可视化程序，读入天气数据及地图数据，生成静态的图片作为可视化输出。

·最终用户通过新浪微博，加载Web应用，看到了可视化生成的静态图片。

·最终用户通过新浪微博分享了这个应用，让更多的人看到这个应用。

下面按照语言的优势，把应用架构按语言的特性来划分，让R语言实现爬虫、处理数据和可视化，让PHP完成Web开发、新浪API接入和用户交互，如图5-9所示。

图5-9　语言优势的系统架构

由于这个应用不需要让R和PHP直接进行通信，那么复杂度就小很多，像我之前做的晒粉丝应用，是3种语言（R、PHP和Java）的结合。通过Java实现中间程序的调度，让R和PHP能够实现通信。我们通过语言的划分，就可以扬长避短，让每种语言在最擅长的领域，完成最擅长的事情。

对于后台技术应用，定时器可以用Linux系统的CRON实现；然后用R语言程序来爬取数据，通过RCurl包来完成；爬取后的数据为XML格式，再通过R语言用XML包进行解析，以CSV格式进行本地存储；接下来，再用R语言处理数据，加载地图包ggmap、mapdata、maptools，最后配合plot（）函数实现图片的输出，保存在本地服务器上。

对于前端的PHP应用来说，用PHP做一个Web网站很简单，使用YII快速开发框架；用PHP的新浪微博SDK进行API操作，实现新浪登陆、新浪分享等功能；最后Nginx+Spawn构建出PHP运行时环境，让Nginx完成负载均衡和图片加载，并配合PHP的访问规则，实现功能的切换。

合理的架构设计加上适当的语言分工，就能轻松实现“每日中国天气”这样的一个微博应用。其实，我们可以用这种多语言混搭的方式，创建出各种创新型的网站应用，但前提是先能掌握多种语言。

大多数程序员都是在自己的技术领域中游刃有余，只是在掌握了一种语言的核心技术并有了一些开发经验后，往往不愿意再去学第二种语言。对这些人来说，总觉得自己就是世界的中心，自己有能力实现所有的功能。这些也都是有理想的程序员，只不过他们进入了一个误区，被现有的技术给迷住了，看不到、也不愿意看到外面的世界已经变了。我曾经就是这样的！

我承认Java是一种无所不能的编程语言，但是如果你所有的程序都用Java实现，难道不觉得费时又费力吗？通用性越强，反而专有领域的应用性就越差。这也是我从Java单一的技术路线走出来的原因。其实，在精通一门语言后，再去学习另外一门新的语言，就不是那么难了。但如果只是沉醉于已掌握的技术，很快就会被一代新人、一代新工具所超越的。

5.3.3　R语言程序实现

下面就开始介绍R语言的部分程序开发，在写代码之前，我们需要先梳理开发流程并做程序设计，R语言都需要实现哪些功能，用到哪些第三方R包。

我用一幅图来说明程序之间的调用关系，R语言的程序实现一共包括了6个部分，即爬虫程序、本地存储、地图加载、数据可视化处理、生成静态图、生成可交互的静态图，如图5-10所示。

图5-10　R语言程序设计

在图5-10中，分别标出了每个步骤用到的R包或者功能函数，同时我们可以按照这个流程来定义功能函数，这样我们就把整个应用程序都规划好，最后再对应地写代码就不难了。

1.爬虫部分

对于爬虫部分来说，就是定时下载每个城市的或地区的天气数据，并解析数据，只保留我们需要的字段，并以CSV的格式存储。互联网上有很多免费公开的天气数据源，对我来说，最方便的数据源有2个，一个是Yahoo的天气数据，另一个是Google的天气数据，但由于Google的API从中国大陆会经常访问不到，所以我在这里选择Yahoo的天气数据源进行访问。

Yahoo天气数据源的访问地址，如下所示。

http://weather.yahooapis.com/forecastrssw=WOEID

其中WOEID代表城市对应的代码，北京对应的WOEID为2151330，如果想查看北京的天气数据，可以用浏览器访问http://weather.yahooapis.com/forecastrssw=2151330。

我们通过浏览器打开地址，就可以看到这个数据，数据是以XML格式进行发布的，如图5-11所示。

图5-11　北京的天气数据

我们要解析这个XML文件，从中找到我们需要的数据进行提取。在R语言中，通过RCurl包实现HTTP的网络访问，抓取到整个的XML文档数据，然后通过XML包解析XML文档的DOM树，就能找到我们需要的数据了。

本节的系统环境是：

·Windows 7 64bit

·R：3.1.1 x86_64-w64-mingw32/x64（64-bit）

当我们把业务逻辑和技术实现都想清楚了，就可以动手写代码了，只十几行代码就能完成爬虫和XML文档解析的功能。

> library（RCurl） # 加载类库
> library（XML）
>
> getWeather<-function （x）{
+ url<-paste（'http：//weather.yahooapis.com/forecastrssw='，x，'&u=c'，sep=""）
# yahoo的数据源地址
+ doc = xmlTreeParse（getURL（url），useInternal = TRUE） # 解析XML文档
+
+ ans<-getNodeSet（doc， "//yweather：atmosphere"）
+ humidity<-as.numeric（sapply（ans， xmlGetAttr， "humidity"）） # 温度
+ visibility<-as.numeric（sapply（ans， xmlGetAttr， "visibility"）） # 能见度
+ pressure<-as.numeric（sapply（ans， xmlGetAttr， "pressure"）） # 气压
+ rising<-as.numeric（sapply（ans， xmlGetAttr， "rising"）） # 气压变动
+
+ ans<-getNodeSet（doc， "//item/yweather：condition"）
+ code<-sapply（ans， xmlGetAttr， "code"） # 天气情况
+
+ ans<-getNodeSet（doc， "//item/yweather：forecast[1]"）
+ low<-as.numeric（sapply（ans， xmlGetAttr， "low"）） # 最高气温
+ high<-as.numeric（sapply（ans， xmlGetAttr， "high"）） # 最低气温
+
+ print（paste（x，'==>'，low，high，code，humidity，visibility，pressure，rising））
+ cbind（low，high，code，humidity，visibility，pressure，rising）
# 以data.frame格式返回
+ }

运行程序，查看返回的结果。

> w<-getWeather（2151330） # 执行爬虫程序
[1] "2151330 ==> 9 13 21 59 4.1 1016.4 0"
> w # 返回的结果集
low high code humidity visibility pressure rising
[1，] "9" "13" "21" "59" "4.1" "1016.4" "0"

对于功能需求来说，一个城市只保存7个字段就行了，其他的XML文档的数据可以全部过滤掉不管。

2.本地存储

我们通过爬虫下载并过滤后的数据，已经是data.frame的格式了，通过write.csv（）函数就把这些数据输出到本地文件系统中保存起来，作为数据的备份。

我们在处理本地存储的过程中，除了要生成一个CSV文件，还包括了文件命名以及把多个城市的数据合并到一个文件存储的问题。下面我们需要再定义两个函数，filename（）函数用于新生成文件的命名，loadDate（）函数用于多个城市数据的加载，合并在一个文件中保存。

城市列表应该是我们需要提前准备好的，我这里只选取了中国的34个城市作为我们要获得的城市天气数据的信息。如果想爬取更多的城市天气数据的信息，那么补充这个列表就行了。城市列表数据文件WOEID.csv：

beijing，2151330，北京，北京市，116.4666667，39.9
shanghai，2151849，上海，上海市，121.4833333，31.23333333
tianjin，2159908，天津，天津市，117.1833333，39.15
chongqing，20070171，重庆，重庆市，106.5333333，29.53333333
harbin，2141166，哈尔滨，黑龙江省，126.6833333，45.75
changchun，2137321，长春，吉林省，125.3166667，43.86666667
shenyang，2148332，沈阳，辽宁省，123.4，41.83333333
hohhot，2149760，呼和浩特，内蒙古自治区，111.8，40.81666667
shijiazhuang，2171287，石家庄，河北省，114.4666667，38.03333333
wulumuqi，26198317，乌鲁木齐，新疆维吾尔自治区，87.6，43.8
lanzhou，2145605，兰州，甘肃省，103.8166667，36.05
xining，2138941，西宁，青海省，101.75，36.63333333
xian，2157249，西安，陕西省，108.9，34.26666667
yinchuan，2150551，银川，宁夏回族自治区，106.2666667，38.33333333
zhengzhou，2172736，郑州，河南省，113.7，34.8
jinan，2168327，济南，山东省，117，36.63333333
taiyuan，2154547，太原，山西省，112.5666667，37.86666667
hefei，2127866，合肥，安徽省，117.3，31.85
wuhan，2163866，武汉，湖北省，114.35，30.61666667
changsha，26198213，长沙，湖南省，113，28.18333333
nanjing，2137081，南京，江苏省，118.8333333，32.03333333
chengdu，2158433，成都，四川省，104.0833333，30.65
guiyang，2146703，贵阳，贵州省，106.7，26.58333333
kunming，2160693，昆明，云南省，102.6833333，25
nanning，2166473，南宁，广西壮族自治区，108.3333333，22.8
lasa，26198235，拉萨，西藏自治区，91.16666667，29.66666667
hangzhou，2132574，杭州，浙江省，120.15，30.23333333
nanchang，26198151，南昌，江西省，115.8666667，28.68333333
guangzhou，2161838，广州，广东省，113.25，23.13333333
fuzhou，2139963，福州，福建省，119.3，26.08333333
taipei，2306179，台北，台湾省，121.5166667，25.05
haikou，2162779，海口，海南省，110.3333333，20.03333333
hongkong，24865698，香港，香港特别行政区，114.1666667，22.3
macau，20070017，澳门，澳门特别行政区，113.5，22.2

字段解释如下：

·第一列，城市的英文名

·第二列，WOEID代码

·第三列，城市的中文名

·第四列，城市所在的省中文名

·第五列，经度（默认为东经）

·第六列，纬度（默认为北纬）

用于生成数据文件的R语言的函数实现如下：

> filename<-function（date=Sys.time（））{ # 文件根据日期来命名
+ paste（format（date， "%Y%m%d"），".csv"，sep=""）
+ }
> loadDate<-function（date）{ # 读取城市列表，调用爬虫函数，合并数据保存到一个文件中。
+ print（paste（'Date'，'==>'，date））
+ city<-read.csv（file="WOEID.csv"，header=FALSE，fileEncoding="utf-8"， encoding="utf-8"）
# 加载城市列表
+ names（city）<-c（"en"，"woeid"，"zh"，'prov'，'long'，'lat'）
+ city<-city[-nrow（city），]
+
+ wdata<-do.call（rbind， lapply（city$woeid，getWeather））
+ w<-cbind（city，wdata）
+ write.csv（w，file=filename（date），row.names=FALSE，fileEncoding="utf-8"）
+ }

运行程序的loadDate（）函数，程序会根据城市列表的数据调用getWeather（）函数自动爬取我们定义的所有城市的天气数据。

> date=Sys.time（）；date # 选择日期
[1] "2014-10-01 13：01：08 CST"
> loadDate（date） # 爬取数据
[1] "Date ==> 2014-10-01 13：01：08"
[1] "2151330 ==> 9 13 21 59 4.1 1016.4 0"
[1] "2151849 ==> 18 23 30 57 9.99 1015.92 0"
[1] "2159908 ==> 12 22 30 58 9.99 1017 0"
[1] "20070171 ==> 16 22 26 79 NA 1013.6 0"
[1] "2141166 ==> 2 13 34 29 9.99 1015.92 0"
[1] "2137321 ==> 3 6 11 81 9.99 1015.92 1"
[1] "2148332 ==> 7 16 34 27 9.99 1015.92 0"
[1] "2149760 ==> 4 19 30 59 9.99 982.05 0"
[1] "2171287 ==> 12 14 11 94 2.49 982.05 2"
[1] "26198317 ==> 12 23 34 52 9.99 1015.92 2"
[1] "2145605 ==> 6 17 20 82 8 812.73 0"
[1] "2138941 ==> 3 21 32 63 9 745.01 0"
[1] "2157249 ==> 13 23 11 91 2.99 1017.9 0"
[1] "2150551 ==> 8 22 28 60 7 1016.8 0"
[1] "2172736 ==> 13 19 32 52 8 1015.92 0"
[1] "2168327 ==> 14 22 32 49 NA 1017 0"
[1] "2154547 ==> 9 18 20 88 1.59 982.05 2"
[1] "2127866 ==> 17 23 34 60 9.99 1015.92 2"
[1] "2163866 ==> 19 26 28 78 6 982.05 2"
[1] "26198213 ==> 21 28 28 65 9.99 982.05 2"
[1] "2137081 ==> 15 23 34 57 9.99 1015.92 2"
[1] "2158433 ==> 19 27 20 69 4.01 1015.92 0"
[1] "2146703 ==> 18 26 28 73 9.99 1015.92 0"
[1] "2160693 ==> 13 23 28 64 9.99 1015.92 2"
[1] "2166473 ==> 24 32 30 62 9.99 982.05 0"
[1] "26198235 ==> -1 15 30 50 NA 643.41 0"
[1] "2132574 ==> 16 23 30 53 9.99 1015.92 0"
[1] "26198151 ==> 21 27 20 75 7 1016.4 0"
[1] "2161838 ==> 25 31 28 58 8 982.05 2"
[1] "2139963 ==> 21 29 28 65 9.99 982.05 0"
[1] "2306179 ==> 24 28 28 70 9.99 982.05 0"
[1] "2162779 ==> 24 31 30 58 9.99 982.05 0"
[1] "24865698 ==> 26 30 30 59 9.99 982.05 2"

程序运行完成后，会在当前目录生成一个名字为20141001.csv的文件。打开20141001.csv文件，这个文件就是接下来用于生成可视化图片的基础数据了。

"en"，"woeid"，"zh"，"prov"，"long"，"lat"，"low"，"high"，"code"，"humidity"，"visibility"， "pressure"，"rising"
"beijing"，2151330，"北京"，"北京市"，116.4666667，39.9，"9"，"13"，"21"，"59"，"4.1"，"1016.4"，"0"
"shanghai"，2151849，"上海"，"上海市"，121.4833333，31.23333333，"18"，"23"，"30"，"57"，"9.99"， "1015.92"，"0"
"tianjin"，2159908，"天津"，"天津市"，117.1833333，39.15，"12"，"22"，"30"，"58"，"9.99"，"1017"，"0"
"chongqing"，20070171，"重庆"，"重庆市"，106.5333333，29.53333333，"16"，"22"，"26"，"79"，NA， "1013.6"，"0"
"harbin"，2141166，"哈尔滨"，"黑龙江省"，126.6833333，45.75，"2"，"13"，"34"，"29"，"9.99"， "1015.92"，"0"
"changchun"，2137321，"长春"，"吉林省"，125.3166667，43.86666667，"3"，"6"，"11"，"81"，"9.99"， "1015.92"，"1"
"shenyang"，2148332，"沈阳"，"辽宁省"，123.4，41.83333333，"7"，"16"，"34"，"27"，"9.99"，"1015.92"，"0"
"hohhot"，2149760，"呼和浩特"，"内蒙古自治区"，111.8，40.81666667，"4"，"19"，"30"，"59"，"9.99"， "982.05"，"0"
"shijiazhuang"，2171287，"石家庄"，"河北省"，114.4666667，38.03333333，"12"，"14"，"11"，"94"， "2.49"，"982.05"，"2"
"wulumuqi"，26198317，"乌鲁木齐"，"新疆维吾尔自治区"，87.6，43.8，"12"，"23"，"34"，"52"，"9.99"， "1015.92"，"2"
"lanzhou"，2145605，"兰州"，"甘肃省"，103.8166667，36.05，"6"，"17"，"20"，"82"，"8"，"812.73"，"0"
"xining"，2138941，"西宁"，"青海省"，101.75，36.63333333，"3"，"21"，"32"，"63"，"9"，"745.01"，"0"
"xian"，2157249，"西安"，"陕西省"，108.9，34.26666667，"13"，"23"，"11"，"91"，"2.99"，"1017.9"，"0"
"yinchuan"，2150551，"银川"，"宁夏回族自治区"，106.2666667，38.33333333，"8"，"22"，"28"，"60"， "7"，"1016.8"，"0"
"zhengzhou"，2172736，"郑州"，"河南省"，113.7，34.8，"13"，"19"，"32"，"52"，"8"，"1015.92"，"0"
"jinan"，2168327，"济南"，"山东省"，117，36.63333333，"14"，"22"，"32"，"49"，NA，"1017"，"0"
"taiyuan"，2154547，"太原"，"山西省"，112.5666667，37.86666667，"9"，"18"，"20"，"88"，"1.59"， "982.05"，"2"
"hefei"，2127866，"合肥"，"安徽省"，117.3，31.85，"17"，"23"，"34"，"60"，"9.99"，"1015.92"，"2"
"wuhan"，2163866，"武汉"，"湖北省"，114.35，30.61666667，"19"，"26"，"28"，"78"，"6"，"982.05"，"2"
"changsha"，26198213，"长沙"，"湖南省"，113，28.18333333，"21"，"28"，"28"，"65"，"9.99"，"982.05"，"2"
"nanjing"，2137081，"南京"，"江苏省"，118.8333333，32.03333333，"15"，"23"，"34"，"57"，"9.99"， "1015.92"，"2"
"chengdu"，2158433，"成都"，"四川省"，104.0833333，30.65，"19"，"27"，"20"，"69"，"4.01"，"1015.92"，"0"
"guiyang"，2146703，"贵阳"，"贵州省"，106.7，26.58333333，"18"，"26"，"28"，"73"，"9.99"，"1015.92"，"0"
"kunming"，2160693，"昆明"，"云南省"，102.6833333，25，"13"，"23"，"28"，"64"，"9.99"，"1015.92"，"2"
"nanning"，2166473，"南宁"，"广西壮族自治区"，108.3333333，22.8，"24"，"32"，"30"，"62"，"9.99"， "982.05"，"0"
"lasa"，26198235，"拉萨"，"西藏自治区"，91.16666667，29.66666667，"-1"，"15"，"30"，"50"，NA，"643.41"，"0"
"hangzhou"，2132574，"杭州"，"浙江省"，120.15，30.23333333，"16"，"23"，"30"，"53"，"9.99"， "1015.92"，"0"
"nanchang"，26198151，"南昌"，"江西省"，115.8666667，28.68333333，"21"，"27"，"20"，"75"，"7"， "1016.4"，"0"
"guangzhou"，2161838，"广州"，"广东省"，113.25，23.13333333，"25"，"31"，"28"，"58"，"8"，"982.05"，"2"
"fuzhou"，2139963，"福州"，"福建省"，119.3，26.08333333，"21"，"29"，"28"，"65"，"9.99"，"982.05"，"0"
"taipei"，2306179，"台北"，"台湾省"，121.5166667，25.05，"24"，"28"，"28"，"70"，"9.99"，"982.05"，"0"
"haikou"，2162779，"海口"，"海南省"，110.3333333，20.03333333，"24"，"31"，"30"，"58"，"9.99"， "982.05"，"0"
"hongkong"，24865698，"香港"，"香港特别行政区"，114.1666667，22.3，"26"，"30"，"30"，"59"，"9.99"， "982.05"，"2"

数据一共有10列，字段解释如下：

·en，城市英文名

·woeid，Yahoo天气API定义的WOEID，用于匹配城市

·zh，城市中文名

·prov，城市所在省的中文名

·long，经度（中国处于东经，不区别东经西经）

·lat，纬度（中国处于北纬，不区别南纬北纬）

·low，最低温度

·high，最高温度

·code，天气概括代码

·humidity，湿度

·visibility，能见度

·pressure，大气压

·rising，气压变动

这样数据就准备好了，那么接下来就可以把天气数据对应到中国行政区地图上了。

3.中国地国加载

R语言通过第三方的地图R包，可以很方便地实现基于地图的可视化或基于地理信息的数据处理。那么R语言是如何做到的呢，答案是通过maps、mapdata、maptools这3个包合作完成的。

我们调用maptools包的readShapePoly（）函数，加载中国行政区地图的数据信息，保存在map的变量中，直接用plot（）函数就可以看到可视化的效果了。[1]地图数据是我提前下载好的，保存放在mapdata目录中，一共有3个文件，即bou2_4p.dbf、bou2_4p.shp和bou2_4p.shx。

> library（maps）
> library（mapdata）
> library（maptools）
> map<-readShapePoly（'mapdata/bou2_4p.shp'） # 加载中国行政区地图数据
> plot（map） # 画出中国行政区图

很神奇，2行就画出中国行政区地图的轮廓。我们再继续来分析map这个变量。先检查一下的map的类型，发现是sp包中定义的SpatialPolygonsDataFrame类型的。

> class（map） # 查看map对象类型
[1] "SpatialPolygonsDataFrame"
attr（，"package"）
[1] "sp"

SpatialPolygonsDataFrame类型我们并不熟悉，再用pryr包的otype查检一下面向对象系统的类型。

> library（pryr）
> otype（map） # 发现是S4类型的data.frame
[1] "S4"

之前4.4节中，我们已经掌握了S4类型的基础知识，在知道map是S4类型的实例后，大概就能猜出这个对象如何使用了。另外从命名上看，SpatialPolygonsDataFrame类型应该是用data.frame存储了SpatialPolygons类型的数据。先通过length（）函数和names（）函数，从data.frame的角度查看map对象，包括7列925行。

> length（map） # 一共有925条记录
[1] 925
> names（map） # data.frame包括有7列
[1] "AREA" "PERIMETER" "BOU2_4M_" "BOU2_4M_ID" "ADCODE93"
[6] "ADCODE99" "NAME"

再通过str（）函数查看map对象第一行数据的静态结构。

> str（map[1，]）
Formal class 'SpatialPolygonsDataFrame' [package "sp"] with 5 slots
..@ data ：'data.frame'： 1 obs. of 1 variable：
.. ..$ AREA： num 54.4
..@ polygons ：List of 1
.. ..$ ：Formal class 'Polygons' [package "sp"] with 5 slots
.. .. .. ..@ Polygons ：List of 1
.. .. .. .. ..$ ：Formal class 'Polygon' [package "sp"] with 5 slots
.. .. .. .. .. .. ..@ labpt ： num [1：2] 127.8 47.9
.. .. .. .. .. .. ..@ area ： num 54.4
.. .. .. .. .. .. ..@ hole ： logi FALSE
.. .. .. .. .. .. ..@ ringDir： int 1
.. .. .. .. .. .. ..@ coords ： num [1：5784， 1：2] 121 121 122 122 122 ...
.. .. .. ..@ plotOrder： int 1
.. .. .. ..@ labpt ： num [1：2] 127.8 47.9
.. .. .. ..@ ID ： chr "0"
.. .. .. ..@ area ： num 54.4
..@ plotOrder ： int 1
..@ bbox ： num [1：2， 1：2] 121.2 43.4 135.1 53.6
.. ..- attr（*， "dimnames"）=List of 2
.. .. ..$ ： chr [1：2] "x" "y"
.. .. ..$ ： chr [1：2] "min" "max"
..@ proj4string：Formal class 'CRS' [package "sp"] with 1 slots
.. .. ..@ projargs： chr NA

从这两个维度观察，我们基本清楚map的结构，map里每一行是一个SpatialPolygonsDataFrame对象，包括5个属性，用于存储地图数据信息。取第一行数据data属性，查看结果，发现是黑龙江省的行政区地图数据。

> map[1，]@data
AREA PERIMETER BOU2_4M_ BOU2_4M_ID ADCODE93 ADCODE99 NAME
0 54.447 68.489 2 23 230000 230000 黑龙江省

用第一行数据画图就得到黑龙江省的行政区地图。

> plot（map[1，]）

如果取前100行数据画图，那么应该是部分省份的行政区地图。

> plot（map[1：100，]）

由于本节并不是地图包的详细介绍，只要了解到map对象的基本使用就行了。

4.数据可视化

完成了地图数据的加载后，再接下来就是数据可视化了。数据可视化，我认为要分成2部分操作，一部分是数据处理，另一部分是可视化输出。

我们先思考一下要怎么进行数据处理才能把天气数据和地图数据结合起来呢。我们的目标是要画出中国各省天气概况，会用到之前过滤出的数据中code的数据，code的数据都是代码，我们还要定义code代码和实际意义的映射关系。Yahoo的源数据中，一共定义了49种天气情况，如code.csv文件所示，根据描述我把相似的天气情况进行合并，最后保留18种天气概况特征。code代码映射文件为lablecode.csv。code.csv文件如下：

"code"，"en"，"zh"，"type"
0，tornado，龙卷风，3
1，tropical storm，热带风暴，2
2，hurricane，暴风，3
3，severe thunderstorms，强雷雨天气，16
4，thunderstorms，雷雨，11
5，mixed rain and snow，雨雪，12
6，mixed rain and sleet，雨雪，12
7，mixed snow and sleet，雨雪，12
8，freezing drizzle，冻毛毛雨，11
9，drizzle，毛毛雨，11
10，freezing rain，冻雨，11
11，showers，阵雨，11
12，showers，阵雨，11
13，snow flurries，小雪，13
14，light snow showers，阵雪，13
15，blowing snow，飞雪，13
16，snow，雪，14
17，hail，冰雹，15
18，sleet，雨雪，12
19，dust，灰尘，5
20，foggy，雾，7
21，haze，薄雾，7
22，smoky，烟雾弥漫，6
23，blustery，大风，3
24，windy，风，4
25，cold，冷，18
26，cloudy，多云，8
27，mostly cloudy （night），满云密布，8
28，mostly cloudy （day），满云密布，8
29，partly cloudy （night），少云，9
30，partly cloudy （day），少云，9
31，clear （night），晴，10
32，sunny，睛，10
33，fair （night），晴，10
34，fair （day），晴，10
35，mixed rain and hail，大雨和冰雹，16
36，hot，热，1
37，isolated thunderstorms，局部雷雨，11
38，scattered thunderstorms，零星雷雨，11
39，scattered thunderstorms，零星雷雨，11
40，scattered showers，零星阵雨，11
41，heavy snow，大雪，14
42，scattered snow showers，零星阵雪，13
43，heavy snow，大雪，14
44，partly cloudy，少云，9
45，thundershowers，雷阵雨，11
46，snow showers，阵雪，13
47，isolated thundershowers，局部雷雨，11
3200，not available，无数据，19

字段解释如下：

·code，源数据天气特征代码

·en，英文描述

·zh，中文描述

·type，分类代码
lablecode.csv文件如下：

"type"，"alias"
1，热
2，风暴
3，大风
4，微风
5，灰尘
6，大雾
7，薄雾
8，多云
9，少云
10，晴
11，阵雨
12，雨夹雪
13，小雪
14，大雪
15，冰雹
16，大雨
17，雷暴雨
18，冷
19，无数据

字段解释如下：

·type，分类代码

·alias，用于显示的别名

有了天气特征定义后，我们再把特征匹配到不同的颜色，并增加图例及文字描述，就生成了最终的中国各省天气概况的静态图片了。

> library（"RColorBrewer"） > getColors2<-function（map，prov，ctype）{
+ #name change to ADCODE99
+ ADCODE99<-read.csv（file="ADCODE99.csv"，header=TRUE，fileEncoding="utf-8"， encoding="utf-8"） + fc<-function（x）{ADCODE99$ADCODE99[which（x==ADCODE99$prov）]}
+ code<-sapply（prov，fc） + f=function（x，y） ifelse（x %in% y，which（y==x），0）； + colIndex=sapply（map$ADCODE99，f，code）； + ctype[which（is.na（ctype））]=19
+ return（ctype[colIndex]） + }
> summary<-function（data=data，output=FALSE，path=''）{
+ colors<-c（rev（brewer.pal（9，"Blues"）），rev（c（'#b80137'，'#8c0287'，'#d93c5d'，'#d98698'， '#f6b400'，'#c4c4a7'，'#d6d6cb'，'#d1b747'，'#ffeda0'））） # 定义18种天气特征对应的颜色 +
+ temp<-data$code
+ title<-"中国各省天气概况"
+ ofile<-paste（format（date，"%Y%m%d"），"_code.png"，sep=""） + sign<-''
+ colors<-rev（colors） + code<-read.csv（file="code.csv"，header=TRUE，fileEncoding="utf-8"， encoding="utf-8"） + labelcode<-read.csv（file="labelcode.csv"，header=TRUE，fileEncoding="utf-8"， encoding="utf-8"） + ctype<-sapply（temp，function（x）{code$type[which（x==code$code）]}） +
+ if（output）png（file=paste（path，ofile，sep=''），width=600，height=600） + layout（matrix（data=c（1，2），nrow=1，ncol=2），widths=c（8，1），heights=c（1，2）） + par（mar=c（0，0，3，12），oma=c（0.2，0.2，0.2，0.2），mex=0.3） + plot（map，border="white"，col=colors[getColors2（map，data$prov，ctype）]） # 地图和天气可视化 + points（data$long，data$lat，pch=19，col=rgb（0，0，0，0.3），cex=0.8） # 标出采样城市 +
+ #======================================= # 图片中的辅助文字 + if（FALSE）{
+ grid（） + axis（1，lwd=0）；axis（2，lwd=0）；axis（3，lwd=0）；axis（4，lwd=0） + }
+ text（100，58， title，cex=2） + text（105，54，format（date，"%Y-%m-%d"）） + text（98，65，paste（'每日中国天气'，'http：//apps.weibo.com/chinaweatherapp'）） + text（120，-8，paste（'provided by The Weather Channel'，format（date， "%Y-%m-%d %H：%M"）），cex=0.8） +
+ #======================================= # 文字说明 + for（row in 1：nrow（data））{
+ name<-as.character（data$zh[row]） + label<-labelcode$alias[labelcode$type==ctype[row]]
+ x1<-ceiling（row/7） + x2<-ifelse（row%%7==0，7，row%%7） + x3<-ctype[row]
+ fontCol<-'#000000'
+ if（x3<=5）fontCol<-head（colors，1） + if（x3>=12）fontCol<-tail（colors，1） + text（68+x1*11，17-x2*3，paste（name，' '，label，sign，sep=''），col=fontCol） + }
+
+ #======================================= # 图例 + par（mar = c（5， 0， 15， 10）） + image（x=1， y=1：length（colors），z=t（matrix（1：length（colors））），col=rev（colors），axes=FALSE， xlab=""，ylab=""，xaxt="n"） + axis（4， at = 1：（nrow（labelcode）-1）， labels=rev（labelcode$alias）[-1]， col = "white"， las = 1） + abline（h=c（1：（nrow（labelcode）-2）+0.5）， col = "white"， lwd = 2， xpd = FALSE） + if（output）dev.off（） + }

运行程序，生成中国各省天气概况的静态图片。

> data<-read.csv（file=filename（date），header=TRUE，fileEncoding="utf-8"， encoding="utf-8"）
# 定义数据源
> path='' # 定义输出路径
> summary（data，output=TRUE，path=path） # 生成中国各省天气概况图
RStudioGD
2

大概100行左右代码就可以生成这么复杂的天气和地图结合的图片，R真的很神奇！

5.可交互的静态图

这是锦上添花的一步，静态图片对于一般应用来说就够了。但如果图片还能动起来，是不是会更吸引人呢？我们可以尝试生成基于HTML5的、有动态效果的图，通过recharts包调Echarts库实现基于HTML5的动画，生成会动的可交互的图片。

由于recharts包没有发布的CRAN，我们需要用devtools包通过Github安装这个包。

> library（devtools） # 加载devtools
> install_github（"taiyun/recharts"） # 下载安装recharts包
> library（recharts） # 加载recharts包

由于上面的天气概况是由离散值组成的，我们需要利用echarts的库做一个连续值的可视化例子，比如白天气温和夜间气温。定义weather_html（）函数，提供气温数据并调用recharts包，实现可视化的输出。

> weather_html<-function（data=data，type='high'，output=FALSE，path=''）{
# 输入HTML的天气图
+ if（type=='high'） { # 白天气温
+ df<-data[，c（'prov'，'high'）]
+ names（df）<-c（"prov"，"气温"）
+ title<-paste（format（date，"%Y-%m-%d"），"中国各省白天气温"，sep=""）
+ ofile<-paste（format（date，"%Y%m%d"），"_day.html"，sep=""）
+ }else if（type=='low'）{ # 夜间气温
+ df<-data[，c（'prov'，'low'）]
+ names（df）<-c（"prov"，"气温"）
+ title<-paste（format（date，"%Y-%m-%d"），"中国各省夜间气温"，sep=""）
+ ofile<-paste（format（date，"%Y%m%d"），"_night.html"，sep=""）
+ }
+
+ df[，1]<-substr（df[，1]，0，2） # 数据格式整理
+ df[which（df$prov=='黑龙'），]$prov<-'黑龙江'
+ df[which（df$prov=='内蒙'），]$prov<-'内蒙古'
+
+ recharts.eMap <- eMap（df， namevar=1， datavar = 2， title=title）
# 数据JSON化处理
+ if（output）{ # 输出HTML文件
+ recharts.eMap$outList[c（'chartid'，'type'）]<-NULL
+ writeLines（unlist（recharts.eMap$outList），paste（path，ofile，sep=''））
+ }else{ # 在浏览器中打开HTML网页
+ plot（recharts.eMap）
+ }
+ }

运行以下程序，以HTML输出中国各省白天气温。

> date<-as.Date（'20141001'，format='%Y%m%d'） # 设置日期
> data<-read.csv（file=filename（date），header=TRUE，fileEncoding="utf-8"， encoding="utf-8"）
# 加载数据
> path='' # 设置文件输出路径
> weather_html（data，type='high'，output=FALSE，path=''） # 输出中国各省白天气温
[1] "气温"
[1] "chart path C：\\Users\\ADMINI~1\\AppData\\Local\\Temp\\RtmpqCHFPY"

程序会自动打开浏览器，呈现HTML的网页。

运行下面的程序，以HTML输出中国各省夜间气温。在网页中，通过鼠标对地图进行交互，移动左下角的温度条，选择最高温度30，最低温度8.8，中国地图中由西南到东北变为灰色，说明这些地区的温度不在8.8到30度之间。当鼠标滑过海南省的时候，海南省呈现黄色，并提示温度为23度。

> weather_html（data，type='low'， output=FALSE，path=''） # 中国各省夜间气温
[1] "气温"
[1] "chart path C：\\Users\\ADMINI~1\\AppData\\Local\\Temp\\RtmpqCHFPY"

如果不需要在浏览器中打开，只想存储生成的网页，可以在程序中设置output为TRUE，当前目录下会生成20141001_night.html的文件。

> weather_html（data，type='low'，output=TRUE，path=''）
[1] "气温"

本节介绍了每日中国天气应用项目完整情况，并完成R语言部分的功能实现。那么下一节，将介绍如何把R语言的功能代码封装成R包。

[1] 本节后面以及5.4节的效果图请读者自己运行R代码查看。

5.4　R包开发——每日中国天气

问题

如何把R语言应用程序封装成R包？

引言

本节将继续5.3节的内容，把我们已经完成的R语言程序，封装成R语言程序包。这个看起来简单的任务，其实要花很多的时间来处理细节。整个的R包开发过程，将按照5.2节的流程进行，为了保证check（）函数的顺利执行，代码有多处改动。

5.4.1　构建项目

在5.3节中，我们写的R程序都在Windows中完成，由于R的跨平台代码有兼容性的问题，我们的应用程序最终将在Linux中发布，所以为了减少发布时不必要的麻烦，我们转到Linux系统中完成R包的开发。

本节的系统环境是：

·Linux：Ubuntu Server 12.04.2 LTS 64bit

·R：3.1.1 x86_64-pc-linux-gnu（64-bit）

·RStudio-Server 0.97.551

在5.2节中，我们其实已经创建好了chinaWeather项目，那么R包的开发将继续在这个项目中进行。进入chinaWeather项目的目录，为了保证5.2节代码的独立性，我单独开一个Git分支，进行本节的R包开发。

~ cd /home/conan/R/chinaWeather # 进入项目目录~ git branch app # 新建分支，名为app~ git checkout app # 切换到分支app~ git branch # 查看当查的分支
* app
master

查看Linux系统中R语言环境变量的设置，字符集是特别要处理的部分。

> sessionInfo（）
R version 3.1.1 （2014-07-10）
Platform： x86_64-pc-linux-gnu （64-bit）
locale：
[1] LC_CTYPE=en_US.UTF-8 LC_NUMERIC=C
[3] LC_TIME=zh_CN.UTF-8 LC_COLLATE=en_US.UTF-8
[5] LC_MONETARY=zh_CN.UTF-8 LC_MESSAGES=en_US.UTF-8
[7] LC_PAPER=zh_CN.UTF-8 LC_NAME=C
[9] LC_ADDRESS=C LC_TELEPHONE=C
[11] LC_MEASUREMENT=zh_CN.UTF-8 LC_IDENTIFICATION=C
attached base packages：
[1] stats graphics grDevices utils datasets methods base

环境准备就绪，下面就可以开始R包开发的工作了。

5.4.2　静态数据

在开始写R包代码之前，我们需要先整理静态数据。这个项目中，静态数据包括了地图数据、WOEID映射数据、天气概况的映射数据、中英文图片可视化数据、测试数据集。对于普通的R应用程序来说可以用CSV格式保存文件在本地，但对于R包项目来说，最好是封装成rda的数据文件，随R包一起打包发布。

首先，我们就要对这些静态数据文件进行整理，新建目录metadata，用于存储原始CSV文件和地图文件。

~ mkdir /home/conan/R/chinaWeather/metadata # 新建目录，并把原数据文件复制到metadata目录~ ls -l /home/conan/R/chinaWeather/metadata # 查看metadata目录
-rw-rw-r-- 1 conan conan 3396 10月 4 22：14 20141001.csv # 测试数据集
-rw-r--r-- 1 conan conan 754 2月 5 2013 ADCODE99.csv # ADCODE99与省份中文映射数据
-rw-r--r-- 1 conan conan 1418 2月 6 2013 code.csv # Yahoo天气概况映射数据
-rw-r--r-- 1 conan conan 214 2月 6 2013 labelcode.csv # 简化后天气概况映射数据
drwxr-xr-x 2 conan conan 4096 4月 23 2013 mapdata # 地图数据目录
-rw-rw-r-- 1 conan conan 1900 2月 4 2013 WOEID.csv # WOEID映射数据~ ls -l /home/conan/R/chinaWeather/metadata/mapdata # 查看地图数据文件
-rw-r--r-- 1 conan conan 86283 4月 10 1999 bou2_4p.dbf
-rw-r--r-- 1 conan conan 1508752 4月 10 1999 bou2_4p.shp
-rw-r--r-- 1 conan conan 7500 4月 10 1999 bou2_4p.shx

把静态数据转换为rda格式的文件，存储在data目录中。

~ mkdir /home/conan/R/chinaWeather/data # 新建目录data~ R # 启动R语言程序。

1.WOEID数据文件WOEID.rda

对WOEID数据进行处理，要把adcode99代码合并到WOEID数据集中。下面合并WOEID.csv文件和ADCODE99.csv文件的数据，生成WOEID.rda的文件。

> WOEID<-read.csv（file="metadata/WOEID.csv"，header=FALSE，fileEncoding="utf-8"， encoding="utf-8"） # 加载WOEID数据集 > names（WOEID）<-c（"en"，"woeid"，"zh"，'prov'，'long'，'lat'） > adcode99<-read.csv（file="metadata/ADCODE99.csv"，header=TRUE，fileEncoding="utf-8"， encoding="utf-8"） # 加载ADCODE99数据集 > fc<-function（row）{
+ code<-adcode99$ADCODE99[which（row[4]==as.character（adcode99$prov））]
+ if（length（code）==0）code=0
+ code
+ }
> WOEID<-cbind（WOEID，adcode99=unlist（apply（WOEID，1，fc））） # 合并数据集 > save（WOEID，file="data/WOEID.rda"） # 生成WOEID.rda文件 > WOEID # 合并后的WOEID数据集 en woeid zh prov long lat adcode99
1 beijing 2151330 北京 北京市 116.46667 39.90000 110000
2 shanghai 2151849 上海 上海市 121.48333 31.23333 310000
3 tianji 2159908 天津 天津市 117.18333 39.15000 120000
4 chongqing 20070171 重庆 重庆市 106.53333 29.53333 500000
5 harbin 2141166 哈尔滨 黑龙江省 126.68333 45.75000 230000
6 changchun 2137321 长春 吉林省 125.31667 43.86667 220000
7 shenyang 2148332 沈阳 辽宁省 123.40000 41.83333 210000
8 hohhot 2149760 呼和浩特 内蒙古自治区 111.80000 40.81667 150000
9 shijiazhuang 2171287 石家庄 河北省 114.46667 38.03333 130000
10 wulumuqi 26198317 乌鲁木齐 新疆维吾尔自治区 87.60000 43.80000 650000
11 lanzhou 2145605 兰州 甘肃省 103.81667 36.05000 620000
12 xining 2138941 西宁 青海省 101.75000 36.63333 630000
13 xian 2157249 西安 陕西省 108.90000 34.26667 610000
14 yinchuan 2150551 银川 宁夏回族自治区 106.26667 38.33333 640000
15 zhengzhou 2172736 郑州 河南省 113.70000 34.80000 410000
16 jinan 2168327 济南 山东省 117.00000 36.63333 370000
17 taiyuan 2154547 太原 山西省 112.56667 37.86667 140000
18 hefei 2127866 合肥 安徽省 117.30000 31.85000 340000
19 wuhan 2163866 武汉 湖北省 114.35000 30.61667 420000
20 changsha 26198213 长沙 湖南省 113.00000 28.18333 430000
21 nanjing 2137081 南京 江苏省 118.83333 32.03333 320000
22 chengdu 2158433 成都 四川省 104.08333 30.65000 510000
23 guiyang 2146703 贵阳 贵州省 106.70000 26.58333 520000
24 kunming 2160693 昆明 云南省 102.68333 25.00000 530000
25 nanning 2166473 南宁 广西壮族自治区 108.33333 22.80000 450000
26 lasa 26198235 拉萨 西藏自治区 91.16667 29.66667 540000
27 hangzhou 2132574 杭州 浙江省 120.15000 30.23333 330000
28 nanchang 26198151 南昌 江西省 115.86667 28.68333 360000
29 guangzhou 2161838 广州 广东省 113.25000 23.13333 440000
30 fuzhou 2139963 福州 福建省 119.30000 26.08333 350000
31 taipei 2306179 台北 台湾省 121.51667 25.05000 710000
32 haikou 2162779 海口 海南省 110.33333 20.03333 460000
33 hongkong 24865698 香港 香港特别行政区 114.16667 22.30000 810000
34 macau 20070017 澳门 澳门特别行政区 113.50000 22.20000 0

我们看到WOEID数据集包括了中文字符，而R语言的rda规范中，要求不能包括ASCII以外的字符集。在执行check（）检查的过程中，就会遇到非法字符集的错误警告。因此，就需要对中文数据集进行特殊转码处理，把中文字符统一转码成unicode来表示，如北京unicode转码后表示为\u5317\u4eac。当数据集用中文显示的时候，需要再反转unicode到中文，这样中文就可以与R语言程序兼容了。

对WOEID的数据集转码处理，我们需要用到stringi包。

> install.packages（"stringi"） # 安装stringi包
> library（"stringi"） # 加载stringi包

通过stri_escape_unicode（）函数，对WOEID数据集的zh和prov列的中文进行unicode转码。

> WOEID$prov<-stri_escape_unicode（WOEID$prov） # 对WOEID$prov列转码
> WOEID$zh<-stri_escape_unicode（WOEID$zh） # 对WOEID$zh列转码
> save（WOEID，file="data/WOEID.rda"，compress=TRUE） # 保存数据集
> head（WOEID） # 查看转码后的WOEID数据集
en woeid zh prov long
lat adcode99 adcode99
1 beijing 2151330 \\u5317\\u4eac\\u5317\\u4eac\\u5e02 116.4667 39.90000 110000 110000
2 shanghai 2151849 \\u4e0a\\u6d77 \\u4e0a\\u6d77\\u5e02 121.4833 31.23333 310000 310000
3 tianji 2159908 \\u5929\\u6d25\\u5929\\u6d25\\u5e02 117.1833 39.15000 120000 120000
4 chongqing 20070171\\u91cd\\u5e86 \\u91cd\\u5e86\\u5e02 106.5333 29.53333 500000 500000
5 harbin 2141166 \\u54c8\\u5c14\\u6ee8 \\u9ed1\\u9f99\\u6c5f\\u7701 126.6833 45.75000
230000 230000
6 changchun 2137321 \\u957f\\u6625 \\u5409\\u6797\\u7701 125.3167 43.86667 220000 220000

我们再试一下，把unicode的数据转码成原来的中文字符，通过stri_unescape_unicode（）函数实现。

> head（stri_unescape_unicode（WOEID$prov））
[1] "北京市" "上海市" "天津市" "重庆市" "黑龙江省" "吉林省"
> head（stri_unescape_unicode（WOEID$zh））
[1] "北京" "上海" "天津" "重庆" "哈尔滨" "长春"

转码的操作正常，所以在遇到非ASCII的字符集，我们就可以用这种方式进行转换了。

2.地图数据文件chinaMap.rda

对地图数据进行处理，加载原始地图数据，生成chinaMap.rda文件。在chinaMap对象中，NAME列是中文字符，在Linux系统中直接加载地图数据时，由于系统默认使用UTF-8的字符编码，所以读GKB类型的字符显示为乱码，我们可以用iconv（）函数进行转码，然后再通过上面介绍的unicode转码方法保存。但由于NAME列数据，我们刚好用不到，一种简单的操作方法就是将NAME列从数据集中去掉。

> library（maps）
> library（mapdata）
> library（maptools）
> chinaMap<-readShapePoly（'metadata/mapdata/bou2_4p.shp'） # 加载地图数据
> head（chinaMap$NAME） # NAME列，非ASCII编码
[1] \xba\xda\xc1\xfa\xbd\xad
[2] \xc4\xda\xc3\xc5\xd7\xd4\xd6\xce\xc7\xf8
[3] \xd0\xae\xce\xe1\xb6\xfb\xd7\xd4\xd6\xce\xc7\xf8
[4] \xbc\xaa\xc1\xd6
[5] \xc1\xc9\xc4\xfe
[6] \xb8\xca\xcb\xe0
33 Levels： \xb0\xb2\xbb\xd5 ... \xd6\xd8\xc7\xec\xca\xd0
> iconv（head（chinaMap$NAME），"gbk"，"UTF-8"） # 把NAME列，转码为UTF-8
[1] "黑龙江省" "内蒙古自治区" "新疆维吾尔自治区" "吉林省" "辽宁省" "甘肃省"
> chinaMap<-chinaMap[，c（1：6）] # 去掉NAME列
> save（chinaMap，file="data/chinaMap.rda"，compress='xz'） # 生成chinaMap.rda文件

3.中英文图片可视化数据props.rda

对于可视化的图片输出时，用中文名的字段显示，生成props.rda文件，中文编码通过转成unicode进行处理。

> props<-data.frame（
+ key=c（'high'，'low'），
+ zh=c（'中国各省白天气温'，'中国各省夜间气温'），
+ en=c（'Daytime Temperature'，'Nighttime Temperature'）
+ ）
> props$zh<-stri_escape_unicode（props$zh）
> save（props，file="data/props.rda"，compress=TRUE）

4.测试数据集weather20141001.rda

以2014年10月01日的天气数据集作为一个demo数据集，生成weather20141001.rda文件，中文编码通过转成unicode进行处理。

> weather20141001<-read.csv（file="metadata/20141001.csv"，header=TRUE，fileEncoding=
"utf-8"， encoding="utf-8"） # 加载数据文件
> weather20141001$prov<-stri_escape_unicode（weather20141001$prov）
# 对weather20141001$prov列转码
> weather20141001$zh<-stri_escape_unicode（weather20141001$zh）
# 对weather20141001$zh列转码
> save（weather20141001，file="data/weather20141001.rda"，compress=TRUE）
# 生成weather20141001.rda文件。

查看data目录下面的文件列表，生成了4个静态数据集文件。

> dir（'data'）
[1] "WOEID.rda" "chinaMap.rda" "props.rda" "weather20141001.rda"

所有的静态数据集都已预先整理好，下面的R包代码，就可以直接使用这些静态数据集了。

5.4.3　编写功能代码

按照函数功能的不同，我们定义4个文件来描述这些函数。

·getData.R，用于定义爬取数据的函数。

·render.R，用于静态图片可视化渲染的函数。

·chinaWeather.R，用于定义各种工具函数。

·chinaWeather-packages.R，用于定义R包内的数据集。

1.文件getData.R

新建文件getData.R，用于爬取数据和XML文档解析，文件中定义了3个函数。

·getWeatherFromYahoo（），从Yahoo的开放数据源，获取天气数据。

·getWeatherByCity（），通过城市英文名，获取当前城市的天气数据。

·getWeather（），获取中国省会城市的天气数据，在WOEID数据集中定义的城市。

~ vi R/getData.R
#' Get weather data from Yahoo openAPI.
#'
#' @importFrom RCurl getURL
#' @importFrom XML xmlTreeParse getNodeSet xmlGetAttr
#' @param woeid input a yahoo woeid
#' @return data.frame weather data
#' @keywords weather
#' @export
#' @examples
#' \dontrun{
#' getWeatherFromYahoo（）
#' getWeatherFromYahoo（2151330）
#' }
getWeatherFromYahoo<-function（woeid=2151330）{
url<-paste（'http：//weather.yahooapis.com/forecastrssw='，woeid，'&u=c'，sep=""）
doc = xmlTreeParse（getURL（url），useInternalNodes=TRUE）
ans<-getNodeSet（doc， "//yweather：atmosphere"）
humidity<-as.numeric（sapply（ans， xmlGetAttr， "humidity"））
visibility<-as.numeric（sapply（ans， xmlGetAttr， "visibility"））
pressure<-as.numeric（sapply（ans， xmlGetAttr， "pressure"））
rising<-as.numeric（sapply（ans， xmlGetAttr， "rising"））
ans<-getNodeSet（doc， "//item/yweather：condition"）
code<-as.numeric（sapply（ans， xmlGetAttr， "code"））
ans<-getNodeSet（doc， "//item/yweather：forecast[1]"）
low<-as.numeric（sapply（ans， xmlGetAttr， "low"））
high<-as.numeric（sapply（ans， xmlGetAttr， "high"））
print（paste（woeid，'==>'，low，high，code，humidity，visibility，pressure，rising））
return（as.data.frame（cbind（low，high，code，humidity，visibility，pressure，rising）））
}
#' Get one city weather Data.
#'
#' @param en input a English city name
#' @param src input data source
#' @return data.frame weather data
#' @keywords weather
#' @export
#' @examples
#' \dontrun{
#' getWeatherByCity（）
#' getWeatherByCity（en="beijing"）
#' }
getWeatherByCity<-function（en="beijing"，src="yahoo"）{
woeid<-getWOEIDByCity（en）
if（src=="yahoo"）{
return（getWeatherFromYahoo（woeid））
}else{
return（NULL）
}
}
#' Get all of city weather Data.
#'
#' @param lang input a language
#' @param src input data source
#' @return data.frame weather data
#' @keywords weather
#' @export
#' @examples
#' \dontrun{
#' getWeather（）
#' }
getWeather<-function（lang="en"，src="yahoo"）{
cities<-getCityInfo（lang）
wdata<-do.call（rbind， lapply（cities$woeid，getWeatherFromYahoo））
return（cbind（cities，wdata））
}

2.文件render.R

新建文件render.R，用于数据处理和静态图片可视化渲染，文件中定义了5个函数。

·getColors（），根据天气情况匹配不同的颜色

·drawBackground（），画出背景

·drawDescription（），画出文字描述

·drawLegend（），画出图例

·drawTemperature（），画出气温及地图结合

~ vi R/render.R
#' match the color with ADCODE99.
#'
#' @param temp the temperature
#' @param breaks cut the numbers
#' @return new color vector
#' @keywords color getColors<-function（temp，breaks）{ f=function（x，y） ifelse（x %in% y，which（y==x），0） colIndex=sapply（chinaMap$ADCODE99，f，WOEID$adcode99） arr <- findInterval（temp， breaks） arr[which（is.na（arr））]=19 return（arr[colIndex]） }
#' Draw the background.
#'
#' @param title the image's title
#' @param date the date
#' @param lang the language zh or en drawBackground<-function（title，date，lang='zh'）{ text（100，58，title，cex=2） text（105，54，format（date，"%Y-%m-%d"）） #text（98，65，paste（'chinaweatherapp'，'http：//apps.weibo.com/chinaweatherapp'）） #text（120，-8，paste（'provided by The Weather Channel'，format（date， "%Y-%m-%d %H：%M"）），cex=0.8） }
#' Draw the description.
#'
#' @importFrom stringi stri_unescape_unicode
#' @param data daily data
#' @param temp the temperature
#' @param lang the language zh or en drawDescription<-function（data，temp，lang='zh'）{ rows<-1：nrow（data） x<-ceiling（rows/7）*11+68 y<-17-ifelse（rows%%7==0，7，rows%%7）*3 fontCols<-c（"#08306B"，"#000000"，"#800026"）[findInterval（temp，c（0，30））+1]
if（lang=='zh'）{ txt<-stri_unescape_unicode（data$zh） text（x，y，paste（txt，temp），col=fontCols） }else{ text（x，y，paste（data$en，temp），col=fontCols） }
#text（x，y，bquote（paste（.（data$en），.（temp），degree，C）），col=fontCols） }
#' Draw the legend.
#'
#' @param breaks cut the numbers
#' @param colors match the color drawLegend<-function（breaks，colors）{ breaks2 <- breaks[-length（breaks）]
par（mar = c（5， 0， 15， 10）） image（x=1， y=0：length（breaks2），z=t（matrix（breaks2）），col=colors[1：length（breaks）-1]， axes=FALSE，breaks=breaks，xlab=""，ylab=""，xaxt="n"） axis（4， at = 0：（length（breaks2））， labels = breaks， col = "white"， las = 1） abline（h = c（1：length（breaks2））， col = "white"， lwd = 2， xpd = FALSE） }
#' Draw temperature picture.
#'
#' @importFrom RColorBrewer brewer.pal
#' @importFrom stringi stri_unescape_unicode
#' @import maptools
#' @param data daily data
#' @param lang language
#' @param type low or high
#' @param date the date
#' @param output output a file or not
#' @param path image output position
#' @export drawTemperature<-function（data，lang='zh'，type='high'，date=Sys.time（），output=FALSE，path=''）{ colors <- c（rev（brewer.pal（9，"Blues"）），"#ffffef"，brewer.pal（9，"YlOrRd"），"#500000"） breaks=seq（-36，44，4） if（type=='high'） { temp<-data$high ofile<-paste（format（date，"%Y%m%d"），"_day.png"，sep=""） }else{ temp<-data$low ofile<-paste（format（date，"%Y%m%d"），"_night.png"，sep=""） }
if（lang=='zh'）{ title<-stri_unescape_unicode（props[which（props$key=='high'），]$zh） }else{ title<-props[which（props$key=='high'），]$en
}
if（output）png（filename=paste（path，ofile，sep=''），width=600，height=600） layout（matrix（data=c（1，2），nrow=1，ncol=2），widths=c（8，1），heights=c（1，2）） par（mar=c（0，0，3，10），oma=c（0.2，0.2，0.2，0.2），mex=0.3） plot（chinaMap，border="white"，col=colors[getColors（temp，breaks）]） points（data$long，data$lat，pch=19，col=rgb（0，0，0，0.3），cex=0.8） drawBackground（title，date，lang） drawDescription（data，temp，lang） drawLegend（breaks，colors） }

3.文件chinaWeather.R

修改文件chinaWeather.R，用于定义各种工具函数，文件中定义了3个函数。

·filename（），根据日期定义文件名称。

·getWOEIDByCity（），通过城市名获得WOEID代码。

·getCityInfo（），查看所有城市的信息，即在WOEID数据集中定义的城市。

#' Define a filename from current date.
#'
#' @param date input a date type
#' @return character a file name
#' @keywords filename
#' @export
#' @examples
#' \dontrun{
#' filename（）
#' filename（as.Date（"20110701"，format="%Y%m%d"））
#' }
filename<-function（date=Sys.time（））{
paste（format（date， "%Y%m%d"），".csv"，sep=""）
}
#' Get WOEID of Yahoo By City Name
#'
#' @param en input a English city name
#' @return integer WOEID
#' @keywords WOEID
#' @export
#' @examples
#' \dontrun{
#' getWOEIDByCity（）
#' getWOEIDByCity（en="beijing"）
#' }
getWOEIDByCity<-function（en="beijing"）{
return（WOEID$woeid[which（WOEID$en==en）]）
}
#' Get all of city info
#'
#' @param lang input a language
#' @return data.frame city info
#' @keywords language
#' @export
#' @examples
#' \dontrun{
#' getCityInfo（）
#' getCityInfo（lang="en"）
#' getCityInfo（lang="zh"）
#' }
getCityInfo<-function（lang="en"）{
if（lang=="en"）return（WOEID[-c（3，4）]）
if（lang=="zh"）return（WOEID[-c（4）]）
}

4.文件chinaWeather-package.R

新建文件chinaWeather-package，用于定义R包的说明和内置数据集。

·NULL，关于chinaWeather包的定义说明。

·'WOEID'，WOEID数据集的描述。

·'chinaMap'，chinaMap数据集的描述。

·'props'，props数据集的描述。

·'weather20141001'，weather20141001数据集的描述。

#' China Weather package.
#'
#' a visualized package for china Weather
#'
#' @name chinaWeather-package
#' @aliases chinaWeather
#' @docType package
#' @title China Weather package.
#' @keywords package
NULL
#' The yahoo code for weather openAPI.
#'
#' @name WOEID
#' @description The yahoo code for weather openAPI.
#' @docType data
#' @format A data frame
#' @source \url{https：//developer.yahoo.com/geo/geoplanet/guide/concepts.html}
'WOEID'
#' China Map.
#'
#' @name chinaMap
#' @description China Map Dataset.
#' @docType data
#' @format A S4 Object.
'chinaMap'
#' Charset for Chinease and English.
#'
#' @name props
#' @description Charset.
#' @docType data
#' @format A data frame
'props'
#' Dataset for 20141001.
#'
#' @name weather20141001
#' @description A demo dataset.
#' @docType data
#' @format A data frame
#' @source \url{http：//weather.yahooapis.com/forecastrssw=2151330}
'weather20141001'

5.4.4　项目配置文件

我们在chinaWeather项目中，增加了好几个函数定义，同时增加了5个包的依赖，那么项目配置文件也需要做相应的修改。需要修改的文件有3个：

·DESCRIPTION，项目描述文件，用于项目全局的配置。

·NAMESPACE，命令空间文件，用于函数的访问权限控制。

·.Rbuildignore，在打包时，用于排除不参与打包的文件。

1.修改文件DESCRIPTION

DESCRIPTION文件，用于全局项目配置，在Imports选项中定义了5个包的依赖，并增加LazyData的选项。

Package： chinaWeather
Type： Package
Title： a visualized package for china Weather
Version： 0.1
Authors@R： "Dan Zhang <bsspirit@gmail.com> [aut， cre]"
Description： a visualized package for china Weather
Depends：
R （>= 3.1.1）
Imports：
RCurl，
XML，
maptools，
RColorBrewer，
stringi
LazyData： TRUE
License： GPL-2
Date： 2014-09-28

2.修改文件NAMESPACE

NAMESPACE文件用于函数的访问控制，我们先手动定义需要输出的函数，稍后运行roxygen2包的document（）函数，NAMESPACE文件会自动更新。

export（drawTemperature）
export（filename）
export（getCityInfo）
export（getWOEIDByCity）
export（getWeather）
export（getWeatherByCity）
export（getWeatherFromYahoo）

3.新建文件.Rbuildignore

在打包的时候，可以排除不相关的文件，比如metadata目录和.gitignore文件等。

.gitignore
dist
metadata
^.*\.Rproj$
^\.Rproj\.user$
README*
NEWS*

我们把R语言代码、函数注释和配置文件，都修改完成了，下面开始调试程序。

5.4.5　调试程序

用devtools包的工具函数，调试程序还是比较简单的。

> library（devtools） # 加载devtools包
> load_all（"/home/conan/R/chinaWeather"） # 加载chinaWeather项目
Loading chinaWeather
> data（package="chinaWeather"） # 查看chinaWeather的数据集
Data sets in package 'chinaWeather'：
WOEID
chinaMap
props
weather20141001

调用weather20141001测试数据集，画出2014年10月01日的白天气温静态图。

> date<-as.Date（as.character（20141001）， format = "%Y%m%d"）
> drawTemperature（weather20141001，date=date）

再画出2014年10月01日的英文的夜间气温图。

> drawTemperature（weather20141001，type='low'，date=date，lang='en'）

生成的可视化图片，完全符合我们的要求。这里偷懒一下，暂时跳过单元测试了。之前我们在代码上已经加了注释，接下来通过roxygen2包生成文档。

> library（roxygen2）
> roxygenize（"/home/conan/R/chinaWeather"）
First time using roxygen2 4.0. Upgrading automatically...
Writing NAMESPACE
Writing chinaWeather-package.Rd
Writing WOEID.Rd
Writing chinaMap.Rd
Writing props.Rd
Writing weather20141001.Rd
Writing filename.Rd
Writing getWOEIDByCity.Rd
Writing getCityInfo.Rd
Writing getWeatherFromYahoo.Rd
Writing getWeatherByCity.Rd
Writing getWeather.Rd
Writing getColors.Rd
Writing drawBackground.Rd
Writing drawDescription.Rd
Writing drawLegend.Rd
Writing drawTemperature.Rd

文件NAMESPACE也被同时更新了，通过自动化的方式，我们又可以少维护一个文件了。运行一切正常，最后就是程序打包。

5.4.6　程序打包

我们把用于打包的程序放到dist目录中，新建dist目录。

~ mkdir /home/conan/R/chinaWeather/dist # 新建目录dist

1.程序打包

执行打包函数build（），它存在于dist目录。

> build（"/home/conan/R/chinaWeather"，path="dist"）
'/usr/lib/R/bin/R' --vanilla CMD build '/home/conan/R/chinaWeather' --no-manual --no-resave-data
* checking for file '/home/conan/R/chinaWeather/DESCRIPTION' ... OK
* preparing 'chinaWeather'：
* checking DESCRIPTION meta-information ... OK
* checking for LF line-endings in source and make files
* checking for empty or unneeded directories
* looking to see if a 'data/datalist' file should be added
* building 'chinaWeather_0.1.tar.gz'
[1] "dist/chinaWeather_0.1.tar.gz"

在本地安装chinaWeather包。

~ R CMD INSTALL dist/chinaWeather_0.1.tar.gz
* installing to library '/home/conan/R/x86_64-pc-linux-gnu-library/3.1'
* installing *source* package 'chinaWeather' ...
** R
** data
*** moving datasets to lazyload DB
** inst
** preparing package for lazy loading
** help
*** installing help indices
** building package indices
** testing if installed package can be loaded
* DONE （chinaWeather）

加载chinaWeather包，下载当天的天气数据，并可视化输出2014年10月05日时时天气情况。

> library（chinaWeather）
> data<-getWeather（lang='zh'）
[1] "2151330 ==> 8 19 28 32 NA 1023.5 0"
[1] "2151849 ==> 17 25 34 51 9.99 1015.92 0"
[1] "2159908 ==> 9 19 30 35 9.99 1015.92 0"
[1] "20070171 ==> 16 26 28 60 NA 1021.7 0"
[1] "2141166 ==> 0 14 34 22 9.99 1015.92 0"
[1] "2137321 ==> 2 16 30 27 9.99 1015.92 2"
[1] "2148332 ==> 6 18 28 35 9.99 1015.92 0"
[1] "2149760 ==> 3 15 30 31 9.99 1015.92 0"
[1] "2171287 ==> 9 22 34 27 9.99 1015.92 2"
[1] "26198317 ==> 9 18 34 55 9.99 1015.92 2"
[1] "2145605 ==> 6 21 32 39 NA 812.73 0"
[1] "2138941 ==> 3 19 32 34 NA 745.01 0"
[1] "2157249 ==> 12 26 32 44 NA 1022 0"
[1] "2150551 ==> 8 21 32 29 16 1022.7 0"
[1] "2172736 ==> 13 24 20 64 1.5 1015.92 0"
[1] "2168327 ==> 9 21 32 44 15 1022.3 0"
[1] "2154547 ==> 6 20 34 26 9.99 1015.92 2"
[1] "2127866 ==> 15 26 34 42 9.99 1015.92 2"
[1] "2163866 ==> 17 28 28 55 4.01 1019.8 0"
[1] "26198213 ==> 17 28 34 33 9.99 1015.92 0"
[1] "2137081 ==> 14 25 30 54 9.99 1015.92 2"
[1] "2158433 ==> 18 28 30 37 9.99 1015.92 2"
[1] "2146703 ==> 11 22 28 53 9.99 1015.92 2"
[1] "2160693 ==> 8 20 30 49 9.99 1015.92 2"
[1] "2166473 ==> 19 29 30 74 9 982.05 2"
[1] "26198235 ==> -1 16 32 20 NA 643.41 0"
[1] "2132574 ==> 16 25 34 39 9.99 1015.92 0"
[1] "26198151 ==> 19 28 30 40 NA 1018.4 0"
[1] "2161838 ==> 20 31 34 31 9.99 982.05 0"
[1] "2139963 ==> 18 27 34 42 9.99 982.05 2"
[1] "2306179 ==> 23 27 28 51 9.99 982.05 0"
[1] "2162779 ==> 23 28 30 66 9.99 982.05 2"
[1] "24865698 ==> 23 29 30 38 9.99 982.05 0"
[1] "20070017 ==> 25 29 34 48 9.99 982.05 2"
> drawTemperature（data，date=Sys.Date（））

2.check检查

打包过程一切正常，接下就是check（）函数检查。从check（）函数的输出来看，我们顺利地通过了检查，但其实程序调试的过程中遇到了很多问题，是一点一点花时间解决的。

> check（"/home/conan/R/chinaWeather"） # 执行check检查
Updating chinaWeather documentation
Loading chinaWeather
'/usr/lib/R/bin/R' --vanilla CMD build '/home/conan/R/chinaWeather' --no-manual --no-resave-data
* checking for file '/home/conan/R/chinaWeather/DESCRIPTION' ... OK
* preparing 'chinaWeather'：
* checking DESCRIPTION meta-information ... OK
* checking for LF line-endings in source and make files
* checking for empty or unneeded directories
* looking to see if a 'data/datalist' file should be added
* building 'chinaWeather_0.1.tar.gz'
'/usr/lib/R/bin/R' --vanilla CMD check '/tmp/Rtmp3YI3Ar/chinaWeather_0.1.tar.gz' --timings
* using log directory '/tmp/Rtmp3YI3Ar/chinaWeather.Rcheck'
* using R version 3.1.1 （2014-07-10）
* using platform： x86_64-pc-linux-gnu （64-bit）
* using session charset： UTF-8
* checking for file 'chinaWeather/DESCRIPTION' ... OK
* checking extension type ... Package
* this is package 'chinaWeather' version '0.1'
* checking package namespace information ... OK
* checking package dependencies ... OK
* checking if this is a source package ... OK
* checking if there is a namespace ... OK
* checking for executable files ... OK
* checking for hidden files and directories ... OK
* checking for portable file names ... OK
* checking for sufficient/correct file permissions ... OK
* checking whether package 'chinaWeather' can be installed ... OK
* checking installed package size ... OK
* checking package directory ... OK
* checking DESCRIPTION meta-information ... OK
* checking top-level files ... OK
* checking for left-over files ... OK
* checking index information ... OK
* checking package subdirectories ... OK
* checking R files for non-ASCII characters ... OK
* checking R files for syntax errors ... OK
* checking whether the package can be loaded ... OK
* checking whether the package can be loaded with stated dependencies ... OK
* checking whether the package can be unloaded cleanly ... OK
* checking whether the namespace can be loaded with stated dependencies ... OK
* checking whether the namespace can be unloaded cleanly ... OK
* checking loading without being on the library search path ... OK
* checking dependencies in R code ... OK
* checking S3 generic/method consistency ... OK
* checking replacement functions ... OK
* checking foreign function calls ... OK
* checking R code for possible problems ... OK
* checking Rd files ... OK
* checking Rd metadata ... OK
* checking Rd line widths ... OK
* checking Rd cross-references ... OK
* checking for missing documentation entries ... OK
* checking for code/documentation mismatches ... OK
* checking Rd \usage sections ... OK
* checking Rd contents ... OK
* checking for unstated dependencies in examples ... OK
* checking contents of 'data' directory ... OK
* checking data for non-ASCII characters ... OK
* checking data for ASCII and uncompressed saves ... OK
* checking examples ... OK
* checking PDF version of manual ... OK

3.Github上传

最后，把项目代码上传到Github中，在Github中开源发布。

~ git add .~ git commit -m 'app~ git push origin app
To https：//github.com/bsspirit/chinaWeatherDemo.git
* [new branch] app -> app

项目的访问地址为https://github.com/bsspirit/chinaWeatherDemo/tree/app，感兴趣的用户可以自行查看源代码。

4.从Github安装chinaWeatherDemo项目

我们把代码上传到Github的同时，就完成了在Github上发布项目，用户可以通过devtools包从Github安装项目。

> library（devtools） # 加载devtools包
> install_github（"bsspirit/chinaWeatherDemo"，ref="app"） # 安装项目，配置app分支
Downloading github repo bsspirit/chinaWeatherDemo@app
Installing chinaWeather
'/usr/lib/R/bin/R' --vanilla CMD INSTALL '/tmp/RtmpTkR2Sd/devtools8435b61dfe5/bsspirit-
chinaWeatherDemo-54e36d4' \
--library='/home/conan/R/x86_64-pc-linux-gnu-library/3.1' --install-tests
* installing *source* package 'chinaWeather' ...
** R
** data
** inst
** preparing package for lazy loading
** help
*** installing help indices
** building package indices
** testing if installed package can be loaded
* DONE （chinaWeather）
Reloading installed chinaWeather

到此为止，整个项目关于R语言的程序开发部分，就全都完成了，接下来就是PHP的部分了。由于本书是一本R语言的图书，所以用PHP构建微博应用的内容请参考笔者的博客，将不在本书中介绍。

第6章　R语言游戏之旅

本章把R语言应用到了游戏领域，虽然R语言并不真正适合做游戏，但是游戏中的各种算法用R语言实现却是既轻巧又简单。在游戏开发的过程中，综合运用了本书的各章知识点，包括环境空间、面向对象、数学计算、R包开发、可视化编程等，从而读者可以更深入地体会到R语言编程的精髓和无限广阔的应用前景。

6.1　R语言键盘和鼠标事件

问题

R语言中如何实现键盘和鼠标交互？

引言

在使用R语言的过程中，很多的技术点会被我们忽略，这些经常被忽略的技术点大都和数据无关。但反过来讲，如果你能掌握这些技术点，你开发的R语言应用会让人觉得Amazing！本节我们就来介绍一下R语言的键盘和鼠标事件。

6.1.1　R语言图形事件

R语言中，应用最广的一类功能是画图，我们会经常使用R语言作图的函数，包括plot（），barplot（），points（），lines（）等。每次调用plot（）函数，R语言的运行环境都会启动一个新的图形设备（graphics device）。这个新打开的图形设备，除了会显示我们定义的图形，还内置了一套事件管理器，可以监听键盘和鼠标事件，实现与图形设备的通信。这个事件管理器在grDevices包中定义，并作为当前环境的父环境应用于用户环境空间中，关于环境空间的解释，请参考3.2节。

试想一下，如果画图程序可以实现与鼠标和键盘通信，那么静态图片也就可以与用户进行交互了。掌握这个功能，R语言将不仅仅用于离线分析，还可以用来做实时应用、聊天工具或者是游戏。接下来，就让我们开始了解一下R语言的图形事件API。

6.1.2　图形事件API

R语言中图形事件API函数有4个：

·setGraphicsEventHandlers，注册图形事件，包括键盘事件和鼠标事件（按下，释放，移动）。

·getGraphicsEvent，启动图形事件监听器，开始监听。

·setGraphicsEventEnv，设置图形设备和环境空间，默认为当前图形设备和当前环境空间。

·getGraphicsEventEnv，获取图形设备，默认为当前图形设备。

要在图形设备中绑定鼠标和键盘事件，我们就需要通过setGraphicsEventHandlers（）函数，把键盘和鼠标事件注册到图形设备中。首先，我们来看这个函数的定义。

> setGraphicsEventHandlers
function （which = dev.cur（）， ...）
setGraphicsEventEnv（which， as.environment（list（...）））
<bytecode： 0x000000000b321d20>
<environment： namespace：grDevices>

通过定义我们只能看到setGraphicsEventHandlers（）又调用了setGraphicsEventEnv（），用来设置图形设备，而setGraphicsEventHandlers（）的参数都用“…”隐藏了。

下面查看getGraphicsEvent（）函数的定义。发现getGraphicsEvent（）函数的参数可用于事件绑定，并且getGraphicsEvent（）的参数，实际上是用来传给setGraphicsEventHandlers（）函数的。

> getGraphicsEvent
function （prompt = "Waiting for input"， onMouseDown = NULL， onMouseMove = NULL，
onMouseUp = NULL， onKeybd = NULL， consolePrompt = prompt）
{
if （！interactive（））
return（NULL）
if （！missing（prompt） || ！missing（onMouseDown） || ！missing（onMouseMove） ||
！missing（onMouseUp） || ！missing（onKeybd）） {
setGraphicsEventHandlers（prompt = prompt， onMouseDown = onMouseDown，
onMouseMove = onMouseMove， onMouseUp = onMouseUp，
onKeybd = onKeybd）
}
.External2（C_getGraphicsEvent， consolePrompt）
}
<bytecode： 0x0000000005c4bd40>
<environment： namespace：grDevices>

各参数说明如下：

·prompt，文字提示

·consolePrompt，在终端中的文字提示

·onMouseDown，鼠标事件，按下鼠标按键

·onMouseUp，鼠标事件，释放鼠标按键

·onMouseMove，鼠标事件，鼠标移动

·onKeybd，键盘事件，按下键盘

这样，通过getGraphicsEvent（）函数的封装，我们可以绑定鼠标事件和键盘事件的操作了。

6.1.3　键盘事件

说完知识点和API，下面我们就要动手写点程序了。本节的系统环境是：

·Windows 7 64bit

·R：3.1.1 x86_64-w64-mingw32/x64（64-bit）

我们先来做一个键盘事件的小程序，要求如下：

（1）利用R语言画图，根据键盘输入显示对应的文字。

（2）每次按键盘，输出一个字母在屏幕上面。

（3）按ctrl+C时，停止键盘事件。

应用截图如图6-1所示。

在图6-1中，左边为R语言程序后台，每次键盘输入，打印一行日志，右边图形设置中间的文字会跟着变化。

注　程序不能在RStudio中运行，必须在命令行窗口运行。

R语言代码实现如下：

> letter<-function（）{ # 字母工具
+ draw<-function（label=''，x=0，y=0）{ # 画图函数
+ plot（x，y，type='n'）
+ text（x，y，label=label，cex=5）
+ }
+ keydown<-function（K）{ # 键盘事件
+ if （K == "ctrl-C"） return（invisible（1））
+ print（K）
+ draw（K）
+ }
+ draw（） # 画图
+ getGraphicsEvent（prompt="Letter Tool"，onKeybd = keydown） # 注册键盘事件，启动监听
+ }
> letter（） #启动程序

图6-1　键盘事件

这个小功能，实现代码还是比较简单的。接下来，我们加上鼠标的事件，做一个稍微复杂点的例子。

6.1.4　鼠标事件

R语言中，图形设备的鼠标事件，包括3种类型，即鼠标移动、鼠标按下（左键、右键、滚轮）、鼠标释放。我们设计一个应用，要求如下：

（1）利用R语言画图，根据鼠标事件指定图形的位置和形状。

（2）每次移动鼠标，左下角输出鼠标所在的坐标，同时一个默认的图形随鼠标移动。

（3）当鼠标按下时，会在当前坐标出现一个图形，左键对应正方形，滚轮对应用圆形，右键对应三角形。

（4）按q时，停止监听事件。

应用截图如图6-2所示。

图6-2　鼠标事件

代码实现如下：

> mouse <- function（） { # 鼠标事件应用 + par（mai=rep（0，4），oma=rep（0，4）） # 设置画布无边 + ps<-data.frame（x=c（0.5），y=c（0.5），col=c（2），pch=c（15）） # 初始化的点 + draw<-function（x=0，y=0）{ # x，y为鼠标坐标 + plot（0，0，xlim=c（0，1），ylim=c（0，1），type='n'，xaxs="i"， yaxs="i"） + abline（h=0.5，col="gray60"） # 水平线 + abline（v=0.5，col="gray60"） # 垂直线 + points（ps$x，ps$y，pch=ps$pch，cex=2，col=ps$col） # 实点标点 + points（x，y，pch=15，cex=2，col=colors（）[ps$col]） # 鼠标坐标点 + text（0.25，0.015，label=paste（x，y，sep="，"）） # 鼠标坐标 + }
+ # 鼠标按键监听：当鼠标按键，会增加一个实点 + # buttons，0是左键，1是滚轮，2是右键 + mouseDown <- function（buttons， x， y） {
+ print（paste（"down"，buttons，x，y）） + shape<-15 # 形状设置 + if（buttons==1） shape<-16
+ if（buttons==2） shape<-17
+ ps<<-rbind（ps，data.frame（x=c（x），y=c（y），pch=c（shape），col=round（runif（1，2，500）））） # 增加实点 + draw（x，y） + }
+ mouseMove <- function（buttons， x， y） { # 鼠标移动监听 + print（paste（"move"，buttons，x，y）） + draw（x，y） + }
+ mouseup <- function（buttons， x， y） { # 鼠标按键释放监听 + print（paste（"up"，buttons，x，y）） + draw（x，y） + }
+ keydown <- function（key） { # 键盘按键监听 + if （key == "q"） return（invisible（1）） + }
+ draw（） # 画初始坐标 + getGraphicsEvent（prompt="mouse"，onMouseDown=mouseDown，onMouseMove=mouseMove， onMouseUp=mouseup，onKeybd=keydown） # 注册事件 + }
> mouse（） # 启动程序

通过对R语言图形设备的事件监听，我们就可以轻松实现鼠标和键盘与程序的交互了，是不是很有意思呢！下一节，让我们来动手做个游戏吧。

6.2　贪食蛇游戏入门

问题

如何用R写贪食蛇游戏？

引言

用R语言进行统计分析不神奇，用R语言做分类算法不神奇，用R语言做可视化也不神奇，你见过用R语言做游戏的吗？本节将带你进入R语言的游戏开发，用R语言实现贪食蛇游戏。

6.2.1　贪食蛇游戏介绍

贪食蛇是一个产生于20世纪70年代中后期的计算机游戏。此类游戏在20世纪90年代由于一些小屏幕设备引入而再度流行，在现在的手机上基本都可安装这个小游戏。在游戏中，玩家操控一条细长的直线蛇，它会不停前进，玩家只能操控蛇的头部朝向（上下左右），一路拾起触碰到之物（水果），并要避免触碰到自身或者其他障碍物。每次贪食蛇吃掉一个食物，它的身体便增长一些。吃掉一些食物后会使蛇的移动速度逐渐加快，让游戏的难度渐渐变大。游戏设置四面都有墙，并且不可以穿越，蛇头碰到墙或障碍物时，游戏结束。以游戏过程吃到的水果数量来计分。贪食蛇游戏，在各种设备上都有实现，已经有很多种版本，如图6-3所示。

图6-3　贪食蛇游戏介绍

6.2.2　场景设计

要开发这款游戏，我们应该如何动手呢？首先，我们需要从软件开发的角度，对这款游戏进行需求分析，列出游戏的规则，并设计业务流程，给出游戏的原型，验证是否可行。

1.需求分析

贪食蛇游戏，应该有3个场景：开机场景、游戏场景和结束场景。

·开机场景：启动程序，在游戏开始前，给用户做准备，并提示如何操作游戏。

·游戏场景：游戏运行中的场景。

·结束场景：当用户胜利、失败或退出时的场景，并提示用户在游戏中的得分。

开机场景和结束场景比较简单，不再解释。游戏场景是整个游戏的核心，包括一块画布、一条蛇、一个蛇头、一个不定长的蛇尾、一个水果、边界和障碍物。

2.游戏规则

下面详细列出游戏进行时的规则。

（1）开始游戏后，用户可以通过上（up）、下（down）、左（left）、右（right）键来操作蛇头，控制蛇的前进方向，还可以按q键直接游戏失败，其他的键盘操作无效。

（2）蛇头用蓝色标识，蛇尾用灰色标识，水果用红色标识，障碍物用黑色标识。

（3）当蛇头移动到水果的位置后，表示蛇吃到了水果，蛇尾的长度加1。水果会在下一次蛇头移动后，在空路径上自动生成。

（4）游戏画布的外围是边界，当蛇头移动到画布看不到的位置，则表示蛇头撞到边界，游戏失败。

（5）游戏画面中，有一些黑色障碍物，当蛇头碰到障碍物，游戏失败。

（6）当蛇头碰到蛇尾时，游戏失败。

3.业务流程

我们把游戏设定为3个场景，那么游戏场景的切换流程，如图6-4所示。

图6-4　业务流程定义

·打开程序时，用户首先看到开机场景，按任意键后进入游戏场景。

·在游戏场景，当游戏失败时，进入结束场景；按q键，则直接游戏失败。

·在结束场景，按空格回到开机场景；按q键，则直接能退出程序。

4.游戏原型

我们先要设计出3个游戏场景的界面，作为游戏研发前的原型设计。左边为开机场景，中间是游戏场景，右边是结束场景，如图6-5所示。

图6-5　贪食蛇游戏场景

接下来，我们根据游戏原型设计，用程序来画出整个游戏的场景。

6.2.3　程序设计

通过上面的功能需求分析，我们已经非常清楚地了解贪食蛇游戏的各种规则和功能需求。接下来，我们要把需求分析中的业务语言，通过技术语言重新描述，并考虑非功能需求，以及R语言相关的技术细节。

1.游戏场景

我们让每个场景对应于一块画布，即每个场景对应一个内存结构。

·开机场景，是静态的，我们可以提前生成这块画布并存储起来，也可以当用户切换时再临时生成，性能开销不大。

·游戏场景，是动态的，每进行一次用户的交互行为或按时间刷新时，都需要重新绘制画布，让游戏场景通过绑定事件来生成画布。由于用户会频繁操作，因此性能开销比较大。

·结束场景，是动态的，在结束场景会显示当次游戏的得分，需要在切换时临时生成。

2.游戏对象

在游戏进行中，会产生很多的对象，如上文中提到的画布、蛇、水果等。这些对象都需要在内存中进行定义并匹配到R程序的数据类型。

画布对象的详细描述：

·画布：用矩阵来描述，画布中每个小方块对应到矩阵中一个数字。

·画布大小：画布的长和宽，分别对应两个数字变量。

·画布坐标：用于画布内小格子的定位，从左到右横坐标是1到20，从底到顶纵坐标为1到20。

·画布索引：用于画布内小格子的定位，按从左到右，从底到顶的顺序，为1到400。

·方格：在画布里最小的单位是方格，按照画面的比例，设置方格的大小。

用矩阵描述的画面对象，如图6-6所示。

图6-6　贪食蛇游戏画布

蛇对象的详细描述。

·蛇头：用一个向量来描述，只有一个方格。游戏开始时，起点位置为坐标（2，2），默认蛇头向上移动，用户打开界面显示位置为（2，3）。

·蛇尾：用数据框来描述，存储不定长度的坐标向量。游戏开始时，蛇尾长度是0。

水果对象的详细描述。

·水果：用一个向量来描述，只有一个方格。游戏开始时，随机出现在空的格子上。当水果被吃掉后，会在空的格子上再随机生成一个水果。

边界和障碍物描述。

·边界：无内存描述，通过计算判断。当蛇头坐标超过矩阵坐标时，触发边界碰撞事件。

·障碍物：用数据框来描述，存储不定长度的坐标向量。

3.游戏事件

游戏过程中，会有3种游戏事件，键盘事件、时间事件和碰撞事件。

·键盘事件：全局事件，用户通过键盘输入而触发的事件，比如上下左右控制蛇的移动方向。

·时间事件：全局事件，系统计时以每0.2秒触发一次时间事件，比如蛇头每0.2秒的移动一格。

·碰撞事件：当蛇头移动时，与非空格子碰撞产生的事情，比如，吃到水果，蛇头撞到蛇尾。

通常情况，上面3种事件分别有3个线程来控制。但由于R语言本身是单线程的设计，而且不支持异步调用，因此我们无法同时实现上面的3个事件监听。取一种折中方案为，全局监听键盘事件，通过键盘事件触发碰撞事件进行碰撞检查，忽略时间事件。

4.游戏控制

在游戏进行中，每个状态我们都需要进行控制的。比如，什么时候生成新的水果，什么时候增加一节尾巴，什么时候游戏结束等。通过定义控制函数，可以方便我们管理游戏运行中的各种游戏状态，整个游戏程序流程如图6-7所示。

图6-7　贪食蛇游戏程序流程

图6-7中每个方块代表一个R语言函数定义。

·run（）：启动函数，用于启动游戏程序。

·keydown（）：监听键盘事件，全局锁定线程。

·stage0（）：创建开机场景，可视化输出。

·stage1（）：创建游戏场景，可视化输出。

·stage2（）：创建结束场景，可视化输出。

·init（）：打开游戏场景时，初始化游戏变量。

·fruit（）：判断并生成水果坐标。

·head（）：生成蛇头移动坐标。

·fail（）：失败检查，判断蛇头是否撞墙或撞蛇尾，如果失败则跳过画图，进入结束场景。

·body（）：生成蛇尾移动坐标。

·drawTable（）：绘制游戏背景。

·drawMatrix（）：绘制游戏矩阵。

通过详细的游戏程序设计过程，我们就把需求分析中的业务语言描述，变成了程序开发中的技术语言描述。经过完整的设计后，最后就剩下写代码了。

6.2.4　R语言实现

用R语言写代码，其实没有几行就可以搞定。按照上面的函数定义，我们把代码像填空一样地写进去就行了。当然，在写代码的过程中，我们需要用到一些R语言特性，让代码更健壮。

本节的系统环境是：

·Windows 7 64bit

·R：3.1.1 x86_64-w64-mingw32/x64（64-bit）

首先是用于启动游戏程序的启动函数run（）。

run<-function（）{
par（mai=rep（0，4），oma=rep（0，4）） # 设置全局画布无边
e<<-new.env（） # 定义全局环境空间，用于封装变量
stage0（） # 启动开机场景
getGraphicsEvent（prompt="Snake Game"，onKeybd=keydown） # 注册键盘事件
}

上面代码中，通过定义环境空间e来存储变量，可以有效地解决变量名冲突和变量污染的问题，关于环境空间的介绍，请参考3.2节和3.3节。

然后是keydown（），用于监听键盘事件，全局锁定线程。

keydown<-function（K）{
print（paste（"keydown："，K，"，stage："，e$stage））； # 打印键盘输入
if（e$stage==0）{ # 开机场景
init（）
stage1（）
return（NULL）
}
if（e$stage==2）{ # 结束场景
if（K=="q"） q（）
else if（K==' '） stage0（）
return（NULL）
}
if（e$stage==1）{ # 游戏场景
if（K == "q"） { # 按q键，切换到结束场景
stage2（）
} else {
if（tolower（K） %in% c（"up"，"down"，"left"，"right"））{
e$lastd<-e$dir
e$dir<-tolower（K）
stage1（）
}
}
}
return（NULL）
}

代码中，参数K为键盘输入。通过对当前所在场景与键盘输入的条件判断，来确定键盘事件的响应。在游戏中，键盘只响应5个键"up"，"down"，"left"，"right"，"q"，分别对应“向上”、“向下”、“向左”、“向右”、“退出”的操作。

stage0（）：创建开机场景，可视化输出。

stage0<-function（）{ # 开机场景
e$stage<-0
plot（0，0，xlim=c（0，1），ylim=c（0，1），type='n'，xaxs="i"， yaxs="i"）
text（0.5，0.7，label="Snake Game"，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（）：创建结束场景，可视化输出。

stage2<-function（）{ # 结束场景
e$stage<-2
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=paste（"Congratulations！ You have eat"，nrow（e$tail），"fruits！"），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）
}

init（）：打开游戏场景时，初始化游戏变量。

init<-function（）{ # 初始化环境变量
e<<-new.env（）
e$stage<-0 # 场景
e$width<-e$height<-20 # 切分格子
e$step<-1/e$width # 步长
e$m<-matrix（rep（0，e$width*e$height），nrow=e$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_fruit<-2 # 水果颜色
e$col_head<-4 # 蛇头颜色
e$col_tail<-8 # 蛇尾颜色
e$col_path<-0 # 路颜色
}

上面代码中，初始化全局的环境空间e，然后将所有需要的变量，定义在e中。

fruit（）：判断并生成水果坐标。

fruit（）：判断并生成水果坐标。
fruit<-function（）{ # 随机的水果点
if（length（index（e$col_fruit））<=0）{ # 不存在水果
idx<-sample（index（e$col_path），1）
fx<-ifelse（idx%%e$width==0，10，idx%%e$width）
fy<-ceiling（idx/e$height）
e$m[fx，fy]<-e$col_fruit
print（paste（"fruit idx"，idx））
print（paste（"fruit axis："，fx，fy））
}
}

fail（）：失败检查，判断蛇头是否撞墙或撞蛇尾，如果失败则跳过画图，进入结束场景。

fail<-function（）{ # 失败检查
if（length（which（e$head<1））>0 | length（which（e$head>e$width））>0）{ # head出边界
print（"game over： Out of ledge."）
keydown（'q'）
return（TRUE）
}
if（e$m[e$head[1]，e$head[2]]==e$col_tail）{ # 蛇头碰到蛇尾
print（"game over： head hit tail"）
keydown（'q'）
return（TRUE）
}
return（FALSE）
}

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 # 方向操作，向右移动
}

body（）：生成蛇尾移动坐标。

body<-function（）{ # 生成蛇头坐标
e$m[e$lastx，e$lasty]<-0
e$m[e$head[1]，e$head[2]]<-e$col_head # snake
if（length（index（e$col_fruit））<=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））
e$m[e$tail[1，]$x，e$tail[1，]$y]<-e$col_path
e$tail<-e$tail[-1，]
e$m[e$lastx，e$lasty]<-e$col_tail
}
print（paste（"snake idx"，index（e$col_head）））
print（paste（"snake axis："，e$head[1]，e$head[2]））
}

drawTable（）：绘制游戏背景。

drawTable<-function（）{ # 画布背景
plot（0，0，xlim=c（0，1），ylim=c（0，1），type='n'，xaxs="i"， yaxs="i"）
# 显示背景表格
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），e$width），y=rep（seq（0，0.95，e$step），each=
e$height），lab=seq（1，e$width*e$height））
text（df$x+e$step/2，df$y+e$step/2，label=df$lab）
}

drawMatrix（）：绘制游戏矩阵。

drawMatrix<-function（）{ # 根据矩阵画数据
idx<-which（e$m>0）
px<- （ifelse（idx%%e$width==0，e$width，idx%%e$width）-1）/e$width+e$step/2
py<- （ceiling（idx/e$height）-1）/e$height+e$step/2
pxy<-data.frame（x=px，y=py，col=e$m[idx]）
points（pxy$x，pxy$y，col=pxy$col，pch=15，cex=4.4）
}

stage1（）：创建游戏场景，stage1（）函数内部封装了游戏场景运行时的函数，并进行调用。

stage1<-function（）{ # 游戏中
e$stage<-1
fruit<-function（）{...} # 见fruit
fail<-function（）{...} # 见fail
head<-function（）{...} # 见head
body<-function（）{...} # 见body
drawTable<-function（）{...} # 见drawTable
drawMatrix<-function（）{...} # 见drawMatrix
fruit（） # 运行函数
head（）
if（！fail（））{ # 失败检查
body（）
drawTable（）
drawMatrix（）
}
}

注　上面代码为伪代码。

最后，是完整的R语言程序代码。

> init<-function（）{ # 初始化环境变量 + e<<-new.env（） + e$stage<-0 #场景 + e$width<-e$height<-20 #切分格子 + e$step<-1/e$width #步长 + e$m<-matrix（rep（0，e$width*e$height），nrow=e$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_fruit<-2 #水果颜色 + e$col_head<-4 #蛇头颜色 + e$col_tail<-8 #蛇尾颜色 + e$col_path<-0 #路颜色 + }
>
> index<-function（col） which（e$m==col） # 获得矩阵的索引值 >
> stage1<-function（）{ # 游戏中 + e$stage<-1
+
+ fruit<-function（）{ # 随机的水果点 + if（length（index（e$col_fruit））<=0）{ #不存在水果 + idx<-sample（index（e$col_path），1） +
+ fx<-ifelse（idx%%e$width==0，10，idx%%e$width） + fy<-ceiling（idx/e$height） + e$m[fx，fy]<-e$col_fruit
+
+ print（paste（"fruit idx"，idx）） + print（paste（"fruit axis："，fx，fy）） + }
+ }
+
+ fail<-function（）{ # 检查失败 + if（length（which（e$head<1））>0 | length（which（e$head>e$width））>0）{
# 蛇头出边界 + print（"game over： Out of ledge."） + keydown（'q'） + return（TRUE） + }
+
+ if（e$m[e$head[1]，e$head[2]]==e$col_tail）{ # 蛇头碰到蛇尾 + print（"game over： head hit tail"） + keydown（'q'） + return（TRUE） + }
+
+ return（FALSE） + }
+
+ 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
+
+ }
+
+ body<-function（）{ # 蛇尾状态 + e$m[e$lastx，e$lasty]<-0
+ e$m[e$head[1]，e$head[2]]<-e$col_head
+ if（length（index（e$col_fruit））<=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）） + e$m[e$tail[1，]$x，e$tail[1，]$y]<-e$col_path
+ e$tail<-e$tail[-1，]
+ e$m[e$lastx，e$lasty]<-e$col_tail
+ }
+
+ print（paste（"snake idx"，index（e$col_head））） + print（paste（"snake axis："，e$head[1]，e$head[2]）） + }
+
+ drawTable<-function（）{ # 画布背景 + plot（0，0，xlim=c（0，1），ylim=c（0，1），type='n'，xaxs="i"， yaxs="i"） + }
+
+ drawMatrix<-function（）{ # 根据矩阵画数据 + idx<-which（e$m>0） + px<- （ifelse（idx%%e$width==0，e$width，idx%%e$width）-1）/e$width+e$step/2
+ py<- （ceiling（idx/e$height）-1）/e$height+e$step/2
+ pxy<-data.frame（x=px，y=py，col=e$m[idx]） + points（pxy$x，pxy$y，col=pxy$col，pch=15，cex=4.4） + }
+
+ fruit（） + head（） + if（！fail（））{
+ body（） + drawTable（） + drawMatrix（） + }
+ }
>
> stage0<-function（）{ # 开机画图 + e$stage<-0
+ plot（0，0，xlim=c（0，1），ylim=c（0，1），type='n'，xaxs="i"， yaxs="i"） + text（0.5，0.7，label="Snake Game"，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（）{ # 结束画图 + e$stage<-2
+ 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=paste（"Congratulations！ You have eat"，nrow（e$tail），"fruits！"）， 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）{ # 键盘事件 + print（paste（"keydown："，K，"，stage："，e$stage））； + if（e$stage==0）{ # 开机画面 + init（） + stage1（） + return（NULL） + }
+
+ if（e$stage==2）{ # 结束画面 + if（K=="q"） q（） + else if（K==' '） stage0（） + return（NULL） + }
+
+ if（e$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） + }
>
> #######################################
> # RUN
> #######################################
>
> run<-function（）{
+ par（mai=rep（0，4），oma=rep（0，4）） + e<<-new.env（） + stage0（） + getGraphicsEvent（prompt="Snake Game"，onKeybd=keydown） # 注册事件 + }
>
> run（）

游戏截图见图6-8。

图6-8　贪食蛇游戏动画

全部代码仅仅161行，而有效代码行只有100行左右，就实现了贪食蛇游戏。当然，时间事件没有实现，只因为R语言本身的单线程机制，而且不支持异步调用。正因为R语言强大的数据处理能力和可视化能力，让我们的程序写起来非常简单。我想如果让R来实现策略类游戏的矩阵部分的计算，一定会非常顺手的。

有了贪食蛇游戏的雏形，再通过面向对象的封装，能不能归纳出一个基于R语言游戏的开发框架呢？下一节将继续R语言游戏之旅，R语言游戏框架设计。

6.3　R语言游戏框架设计

问题

如何用R语言写游戏框架？

引言

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

6.3.1　贪食蛇的面向对象改造

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

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

1.定义Snake类

定义Snake类，包括属性和方法，画出类图，如图6-9所示。

图6-9　Snake类定义

属性解释如下。

·name：游戏的名字。

·stage：当前的游戏场景。

·e：用环境空间存储游戏中的变量，environment类型。

·width：矩阵的宽。

·height：矩阵的高。

·m：游戏地图矩阵。

下面是方法解释。

·initialize（）：构建函数，用于RC类的初始化。

·init（）：给stage1场景初始化游戏变量。

·fail（）：失败检查。

·fruit（）：判断并生成水果坐标。

·head（）：生成蛇头移动坐标。

·body（）：生成蛇尾移动坐标。

·drawTable（）：绘制游戏背景。

·drawMatrix（）：绘制游戏矩阵。

·stage0（）：创建开机场景，可视化输出。

·stage1（）：创建游戏场景，stage1（）函数内部，封装了游戏场景运行时的函数，并进行调用。

·stage2（）：创建结束场景，可视化输出

·keydown（）：监听键盘事件。

·run（）：启动函数。

2.全局函数调用顺序图

接下来，根据UML规范画出顺序图，主要包括全局函数调用和stage1场景游戏环境调用。全局函数调用关系，如图6-10所示。

图6-10　游戏全局函数调用过程

·通过run（）函数启动游戏，进入stage0场景，注册键盘事件。

·在stage0场景按任意键切换到stage1场景。

·init（）初始化stage1场景的游戏变量。

·stage1（）运行游戏。

·当游戏失败fail（）或按q键。

·游戏进行stage2场景，显示游戏结束画面。

·按空格键回到stage0重新开始，按q键退出程序。

3.stage1场景游戏环境函数调用顺序图
stage1场景游戏环境函数调用关系，如图6-11所示。

图6-11　游戏stage1场景函数调用过程

·游戏进入stage1场景，按上（up）、下（down）、左（left）、右（right）方向键操作蛇头的前进路线。

·fruit（）函数检查，如果地图上水果被吃掉，生成一个新水果，记录到矩阵中。

·head（）函数，通过上下左右键的操作，进行蛇头的移动，记录到矩阵中。

·fail（）函数失败检查，no未失败继续，yes失败进行stage2场景。

·body（）函数，蛇身体移动，记录到矩阵中。

·drawTable（）函数，画出游戏背景画布。

·drawMatrix（）函数，画出游戏矩阵。

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

6.3.2　游戏框架定义

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

图6-12　贪食蛇的类图

·Game类公共属性，包括了所有的Snake类的属性，这是因为这些属性都是全局的，其他的游戏也会用到，而且每个游戏中的属性，可以在变量e中进行扩展。

·Game类公共方法，包括了游戏全局调用的方法，但不包括Snake游戏stage1场景中运行的方法。在Game类的方法中，我们主要实现的都是开发的辅助功能。

·Snake类方法，有一些是从Game类继承的方法，这是用到方法的重写技术。子类的方法，先调用父类的同名方法，然后再执行子类方法里的程序。

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

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

本节的系统环境是：

·Windows 7 64bit

·R：3.1.1 x86_64-w64-mingw32/x64（64-bit）

Game类的代码实现，用R语言基于RC面向对象编程进行代码编写，新建game.r文件代码如下。

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类，并实现贪食蛇游戏的私有方法，新建snake.r文件代码如下所示。

# 引用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_fruit<<-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） }
}， # 随机的水果点 fruit=function（）{ if（length（index（e$col_fruit））<=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_fruit if（debug）{ print（paste（"fruit idx"，idx）） print（paste（"fruit 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_fruit））<=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（） fruit（） 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的程序，就完成了整个贪食蛇游戏。游戏运行效果，可以查看6.2节的游戏截图，即图6-8。

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

6.4　R语言制作游戏2048

问题

如何用R语言实现2048游戏？

引言

150行代码写出游戏2048，哪种语言能实现？答案是R语言。虽然R语言并不适合做游戏开发，但是R语言中的向量计算，能极大地简化矩阵算法代码实现的复杂度，可以高效地完成计算任务。如果我们把游戏问题变成数学问题，那么R就是绝佳的工具。

6.4.1　2048游戏介绍

2048是一款单人在线和移动端游戏，由19岁的意大利人Gabriele Cirulli于2014年3月开发。游戏任务是在一个网格上滑动小方块来进行组合，直到形成一个带有数字2048的方块，它是滑块类游戏的一种电脑变体。作者开发这个游戏是为了测试自己是否有能力从零开始创造一款游戏，但游戏飙升的人气（不到1周内有400万访客）完全出乎他的预料。事实上，它已被称为网络上“最上瘾的东西”，华尔街日报将其评价为“属于数学极客的Candy Crush”，游戏截图如图6-13所示。

图6-13　2048游戏截图

该游戏为开源软件，这导致它衍生出许多改进版和变种，包括积分排行榜、提升的触屏可玩性等。2048是基于HTML5的JavaScript应用，源代码的地址为https://github.com/gabrielecirulli/2048，免费的在线版本地址为http://gabrielecirulli.github.io/2048/。本文中R语言的程序实现，完全是笔者的个人想法，与游戏作者的JS源代码无关。

该游戏使用方向键让方块上下左右移动。如果两个带有相同数字的方块在移动中碰撞，则它们会合并为一个数字，为两者之和。每次移动时，会有一个值为2或者4的新方块出现。当值为2048的方块出现时，游戏即胜利，该游戏因此得名。

6.4.2　场景设计

接下来，就回到游戏设计环节，同6.2节中贪食蛇入门一样。要开发2048这款游戏，我们应该如何动手呢？我们需要从软件开发的角度，对这款游戏进行需求分析，列出游戏的规则，并设计业务流程，给出游戏的原型，验证是否可行。

1.需求分析

2048游戏，应该有3个场景，即开机场景、游戏场景和结束场景。

·开机场景：启动程序，在游戏开始前，给用户做准备，并提示如何操作游戏。

·游戏场景：游戏运行中的场景。

·结束场景：当用户胜利、失败或退出时的场景，并提示用户在游戏中的得分。

开机场景和结束场景比较简单，不再解释。游戏场景，包括一块4*4的画布，画面中每个格子对应一个数字，数字大于0的格子有背景颜色填充。

2.游戏规则

游戏进行时的规则：

（1）开始游戏后，用户可以通过上（up）、下（down）、左（left）、右（right）键，来控制画布中数字的移动。

（2）如果两个相同的数字在移动中碰撞，则它们会合并为一个，且数字变为两者之和。

（3）每次移动时，会有一个值为2或者4的新数字在空白格子上出现。

（4）当用户按键操作，数字的顺序未发生变化时，则不会生成新数字，视为无效的按键操作。

（5）当画布格子被数字填满时，但在上下左右方向都没可合并的数字时，则游戏失败。

3.业务流程

把游戏设定为3个场景，那么游戏场景的切换流程，如图6-14所示，具体说明如下。

图6-14　2048游戏业务流程定义

·打开程序时，用户首先看到开机场景，按任意键后进入游戏场景。

·在游戏场景，当游戏失败，进入结束场景；按q键，则直接游戏失败。

·在结束场景，按空格回到开机场景；按q键，则直接能退出程序。

从图6-14看出，2048游戏的业务流程，同贪食蛇游戏的业务流程。

4.游戏原型

我们画出3个场景的界面。左边为开机场景，中间是游戏场景，右边是结束场景，如图6-15所示。

图6-15　2048游戏场景

根据游戏原型的图，用程序画出游戏的场景。

6.4.3　程序设计

通过上面的功能需求分析，我们已经非常清楚地了解2048游戏的各种规则和功能。接下来，我们要把需求分析中的业务语言，通过技术语言重新描述，并考虑非功能需求，以及R语言相关的技术细节。

1.游戏场景

我们让每个场景对应一块画布，即每个场景对应一个内存结构。

·开机场景，是静态的，我们可以提前生成好这块画布存储起来，也可以当用户切换时再临时生成，性能开销不大。

·游戏场景，是动态的，每进行一次用户的交互行为或按时间刷新时，都需要重新绘制画布，让游戏场景通过绑定事件来生成画布。

·结束场景，是动态的，在结束场景会显示当次游戏的得分，需要在切换时临时生成。

2.游戏对象

在游戏进行中，会产生很多的对象，如上文中提到的。这些对象都需要在内存中进行定义，然后匹配到对应程序语言的数据类型。

比起贪食蛇游戏，2048游戏要简单很多，我只需要定义一个画布对象就行了。

·画布对象：用矩阵来描述。

·画布中的数字：用矩阵中的数字值来表示。

·画布的背景色：用矩阵中的数字值来表示。

通过矩阵来描述游戏画布和对象，矩阵结构如下所示：

[，1] [，2] [，3] [，4]
[1，] 4 32 4 32
[2，] 32 16 2 4
[3，] 4 2 8 2
[4，] 2 8 2 0

对应的游戏画布，如图6-16所示。

图6-16　2048游戏画布

3.游戏事件

游戏过程中，会有2种事件，键盘事件和碰撞事件。

·键盘事件：是全局事件，用户通过键盘输入而触发的事件，比如，上下左右键的操作，用来控制数字合并的方向。

·碰撞事件：如果两个相同的数字在移动中发生碰撞，则它们会合并为一个数字。

游戏过程中，全局监听键盘事件，用键盘事件触发碰撞事件，检查游戏状态。

4.游戏控制

在游戏进行中，每个状态都需要进行控制。比如，什么时候生成新的数字，什么时候合并相同的数字，什么时候游戏结束等。通过定义控制函数，可以方便我们管理游戏运行中的各种游戏状态，如图6-17所示。

图6-17　2048游戏程序流程

图6-17中每个方块代表一个R语言函数定义。

·run（）：启动程序。

·keydown（）：监听键盘事件，锁定线程。

·stage0（）：创建开机场景，可视化输出。

·stage1（）：创建游戏场景，可视化输出。

·stage2（）：创建结束场景，可视化输出。

·init（）：打开游戏场景时，初始化游戏变量。

·create（）：判断并生成数字。

·move（）：移动数字。

·lose（）：失败查询，判断当画布格子是否被数字填满且不能合并数字时，进行结束场景。

·drawTable（）：绘制游戏背景。

·drawMatrix（）：绘制游戏矩阵。

通过程序设计过程，我们就把需求分析中的业务语言描述，变成了程序开发中的技术语言描述。经过完整的设计后，最后就剩下写代码了。

6.4.4　R语言实现

按照上面的函数定义，我们就可以把代码像填空一样地写进去了。由于我们之前已经做好了一个游戏框架，场景函数及功能函数定义已在框架中实现了一部分，剩下只填入游戏逻辑的代码就行了。关于R语言游戏框架介绍，请参考6.3节。

本节的系统环境是：

·Windows 7 64bit

·R：3.1.1 x86_64-w64-mingw32/x64（64-bit）

1.数字移动函数move（）

2048游戏算法上最复杂的操作，就是数字移动。在4*4的矩阵中，数字会按上下左右四个方向移动，相同的数字在移动中如果碰撞就会进行合并。这个算法是2048游戏的核心算法，我们的程序要保证数字合并的正确性。

我们先把这个函数从框架中抽出来，单独进行实现和单元测试。构建函数moveFun（），这里简化移动过程，只考虑左右移动，后面再通过翻转的计算，让上下移动和左右移动的核心算法共用一套代码。

> moveFun<-function（x，dir）{ # 移动函数
+ if（dir == 'right'） x<-rev（x） # 如果向右移动，则倒叙排列
+
+ len0<-length（which（x==0）） # 0长度
+ x1<-x[which（x>0）] #去掉0
+ pos1<-which（diff（x1）==0） # 找到挨着相等的元素的位置
+
+ if（length（pos1）==3）{ # 3个索引
+ pos1<-pos1[c（1，3）]
+ }else if（length（pos1）==2 && diff（pos1）==1）{ # 2个索引
+ pos1<-pos1[1]
+ }
+
+ x1[pos1]<-x1[pos1]*2
+ x1[pos1+1]<-0
+
+ x1<-x1[which（x1>0）] # 去掉0
+ x1<-c（x1，rep（0，4））[1：4] # 补0，取4个
+
+ if（dir == 'right'） x1<-rev（x1）
+ return（x1）
+ }

接下来，为了检验函数moveFun（）的正确性，我们使用单元测试工具包testthat来检验算法是否正确。关于testthat包的介绍，请参考5.2节。

按游戏规则我们模拟数字左右移动，验证计算结果是否与我们给出的目标值相同，如图6-18所示。R语言单元测试的代码如下。

> library（testthat） > x<-c（4，2，2，2） > expect_that（moveFun（x，'left'）， equals（c（4，4，2，0））） > expect_that（moveFun（x，'right'）， equals（c（0，4，2，4））） > x<-c（4，4，2，4） > expect_that（moveFun（x，'left'）， equals（c（8，2，4，0））） > expect_that（moveFun（x，'right'）， equals（c（0，8，2，4））） > x<-c（2，2，0，2） > expect_that（moveFun（x，'left'）， equals（c（4，2，0，0））） > expect_that（moveFun（x，'right'）， equals（c（0，0，2，4））） > x<-c（2，4，2，4） > expect_that（moveFun（x，'left'）， equals（c（2，4，2，4））） > expect_that（moveFun（x，'right'）， equals（c（2，4，2，4））） > x<-c（4，4，2，2） > expect_that（moveFun（x，'left'）， equals（c（8，4，0，0））） > expect_that（moveFun（x，'right'）， equals（c（0，0，8，4））） > x<-c（2，2，4，4） > expect_that（moveFun（x，'left'）， equals（c（4，8，0，0））） > expect_that（moveFun（x，'right'）， equals（c（0，0，4，8））） > x<-c（4，4，0，4） > expect_that（moveFun（x，'left'）， equals（c（8，4，0，0））） > expect_that（moveFun（x，'right'）， equals（c（0，0，4，8））） > x<-c（4，0，4，4） > expect_that（moveFun（x，'left'）， equals（c（8，4，0，0））） > expect_that（moveFun（x，'right'）， equals（c（0，0，4，8））） > x<-c（4，0，4，2） > expect_that（moveFun（x，'left'）， equals（c（8，2，0，0））） > expect_that（moveFun（x，'right'）， equals（c（0，0，8，2））） > x<-c（2，2，2，2） > expect_that（moveFun（x，'left'）， equals（c（4，4，0，0））） > expect_that（moveFun（x，'right'）， equals（c（0，0，4，4））） > x<-c（2，2，2，0） > expect_that（moveFun（x，'left'）， equals（c（4，2，0，0））） > expect_that（moveFun（x，'right'）， equals（c（0，0，2，4）））

图6-18　2048游戏算法测试

当然我们还可以写更多的测试用例来检验函数计算的正确性。单元测试全部正确，这样就实现了数字移动的核心算法了。

2.其他函数实现

接下来，我们还要完成其他的函数实现，代码结构同贪食蛇游戏。

开机场景函数stage0（）。

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（）。

stage2=function（）{ # 结束画图
callSuper（）
info<-paste（"Congratulations！ You have max number"，max（m），"！"）
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$dir<<-tolower（K）
print（e$dir）
stage1（）
}
}
return（NULL）
}
return（NULL）
}

游戏场景初始化函数init（）。

init = function（）{ # 初始化变量
callSuper（） # 调父类
e$max<<-4 # 最大数字
e$step<<-1/width #步长
e$dir<<-'up'
e$colors<<-rainbow（14） #颜色
e$stop<<-FALSE #不满足移动条件
create（）
}

随机产生一个新数字函数create（）。

create=function（）{ # 随机产生一个新数字
if（length（index（0））>0 & ！e$stop）{
e$stop<<-TRUE
one<-sample（c（2，4），1）
idx<-ifelse（length（index（0））==1，index（0），sample（index（0），1））
m[idx]<<-one
}
}

失败条件函数lose（）。

lose=function（）{ #失败条件
near<-function（x）{ # 判断是否有相邻的有重复值
length（which（diff（x）==0））
}
if（length（index（0））==0）{ # 判断无空格子
h<-apply（m，1，near） # 水平方向
v<-apply（m，2，near） # 垂直方向
if（length（which（h>0））==0 & length（which（v>0））==0）{
fail（"No free grid."）
return（NULL）
}
}
}

游戏画布函数drawTable（）。

drawTable=function（）{ # 画布背景
if（isFail） return（NULL）
plot（0，0，xlim=c（0，1），ylim=c（0，1），type='n'，xaxs="i"， yaxs="i"）
abline（h=seq（0，1，e$step），col="gray60"） # 水平线
abline（v=seq（0，1，e$step），col="gray60"） # 垂直线
}

游戏矩阵函数drawMatrix（）。

drawMatrix=function（）{ # 根据矩阵画数据
if（isFail） return（NULL）
a<-c（t（m））
lab<-c（a[13：16]，a[9：12]，a[5：8]，a[1：4]）
d<-data.frame（x=rep（seq（0，0.95，e$step），width），y=rep（seq（0，0.95，e$step），each=height），
lab=lab）
df<-d[which（d$lab>0），]
points（df$x+e$step/2，df$y+e$step/2，col=e$colors[log（df$lab，2）]，pch=15，cex=23）
text（df$x+e$step/2，df$y+e$step/2，label=df$lab，cex=2）
}

游戏场景函数stage1（）。

stage1=function（）{ # 游戏场景
callSuper（）
move（）
lose（）
create（）
drawTable（）
drawMatrix（）
}

最后，完整的程序代码保存在2048.r文件中，如下所示。

source（file="game.r"） #加载游戏框架 # Snake类，继承Game类 G2048<-setRefClass（"G2048"，contains="Game"， methods=list（ # 构造函数 initialize = function（name，debug） { callSuper（name，debug） # 调父类 name<<-"2048 Game"
width<<-height<<-4
}， # 初始化变量 init = function（）{ callSuper（） # 调父类 e$max<<-4 # 最大数字 e$step<<-1/width # 步长 e$dir<<-'up'
e$colors<<-rainbow（14） # 颜色 e$stop<<-FALSE # 不满足移动条件 create（） }， # 随机产生一个新数字 create=function（）{ if（length（index（0））>0 & ！e$stop）{ e$stop<<-TRUE one<-sample（c（2，4），1） idx<-ifelse（length（index（0））==1，index（0），sample（index（0），1）） m[idx]<<-one
}
}， #失败条件 lose=function（）{
# 判断是否有相邻的有重复值 near<-function（x）{ length（which（diff（x）==0）） }
# 无空格子 if（length（index（0））==0）{ h<-apply（m，1，near） # 水平方向 v<-apply（m，2，near） # 垂直方向 if（length（which（h>0））==0 & length（which（v>0））==0）{ fail（"No free grid."） return（NULL） }
}
}， # 方向移动 move=function（）{
# 方向移动函数 moveFun=function（x）{ if（e$dir %in% c（'right'，'down'）） x<-rev（x） len0<-length（which（x==0）） # 0长度 x1<-x[which（x>0）] # 去掉0 pos1<-which（diff（x1）==0） # 找到挨着相等的元素的位置 if（length（pos1）==3）{ # 3个索引 pos1<-pos1[c（1，3）]
}else if（length（pos1）==2 && diff（pos1）==1）{ # 2个索引 pos1<-pos1[1]
}
x1[pos1]<-x1[pos1]*2 x1[pos1+1]<-0 x1<-x1[which（x1>0）] # 去掉0 x1<-c（x1，rep（0，4））[1：4] # 补0，取4个 if（e$dir %in% c（'right'，'down'）） x1<-rev（x1） return（x1） }
last_m<-m if（e$dir=='left'） m<<-t（apply（m，1，moveFun）） if（e$dir=='right'） m<<-t（apply（m，1，moveFun）） if（e$dir=='up'） m<<-apply（m，2，moveFun） if（e$dir=='down'） m<<-apply（m，2，moveFun） e$stop<<-ifelse（length（which（m ！= last_m））==0，TRUE，FALSE） }， # 画布背景 drawTable=function（）{ if（isFail） return（NULL） plot（0，0，xlim=c（0，1），ylim=c（0，1），type='n'，xaxs="i"， yaxs="i"） abline（h=seq（0，1，e$step），col="gray60"） # 水平线 abline（v=seq（0，1，e$step），col="gray60"） # 垂直线 }， # 根据矩阵画数据 drawMatrix=function（）{ if（isFail） return（NULL） a<-c（t（m）） lab<-c（a[13：16]，a[9：12]，a[5：8]，a[1：4]） d<-data.frame（x=rep（seq（0，0.95，e$step），width），y=rep（seq（0，0.95，e$step），each= height），lab=lab） df<-d[which（d$lab>0），]
points（df$x+e$step/2，df$y+e$step/2，col=e$colors[log（df$lab，2）]，pch=15，cex=23） text（df$x+e$step/2，df$y+e$step/2，label=df$lab，cex=2） }， # 游戏场景 stage1=function（）{ callSuper（） move（） lose（） create（） 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 max number"，max（m），"！"） 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$dir<<-tolower（K） stage1（） }
}
return（NULL） }
return（NULL） } ）） # 封装启动函数 g2048<-function（）{ game<-G2048$new（） game$initFields（debug=TRUE） game$run（） }
# 启动游戏 g2048（）

游戏截图，所6-19所示。

图6-19　2048游戏动画

全部代码仅仅190行，有效代码行只有150行左右，我们就实现了2048游戏。用R语言处理矩阵的向量计算，还是很方便的。另外我们又用面向对象的方法，对游戏程序进行了统一的封装，标准化了函数定义和接口，让我们能更专注于游戏算法本身，提高开发的效率。再下一步，就可以把游戏这个框架项目打包发布到R的官方库CRAN了。

6.5　发布gridgame游戏包

问题

如何发布自己的R软件包？

引言

为了能发布自己的游戏包，我们已经储备了很多的基础知识，包括R语言面向对象编程、R包开发编程、R语言游戏编程等，最后一步就到综合运用的时候了。按CRAN的R包发布的要求，把所有代码和文档串起来，就是我们要发布的gridgame游戏包。

6.5.1　知识储备

在综合运用所有知识前，先回顾一下，我们都需要掌握哪些知识。（1）R语言编程的基础是必需。（2）游戏的算法主要是对矩阵操作，线性代数最好也要掌握。（3）游戏操作需要有界面，虽然不需要太好看，但我们也要有能力用代码画出游戏界面来。（4）游戏的框架封装，对于相同类型的游戏，如果第二款游戏能延续第一款游戏的结构，不仅能简化开发节约时间，还能降低游戏技术门槛，就需要用面向对象的思维模式对游戏框架进行封装。

1.基础知识

上面列出的4个主要知识点，都已经做好了技术准备，针对不同问题，参考不同章节内容就可以解决。

·R语言面向对象编程：R语言基于RC的面向对象编程（4.4节）。

·R语言环境空间：揭开R语言中环境空间的神秘面纱（3.2节），解密R语言函数的环境空间（3.3节）。

·R语言游戏编程：R语言键盘和鼠标事件（6.1节），贪食蛇游戏入门（6.2节），R语言游戏框架设计（6.3节），R语言制作游戏2048（6.4节）。

·R包开发编程：从头开发自己的R包（5.1节），标准化R包开发流程（5.2节）。

2.给R包起名

技术准备一切就绪，先给项目起个名字吧！其实，起名也是有讲究的，不能太随便，虽然CRAN上面没有叫game的包，但我们直接用game作为项目名字，也不是很好。那么如何起名呢？先问问Google，找到一个没有太多重名的关键字作为名字。

直接用google搜索'game'有1100000000条结果，搜索'r game'有1680000000条结果，如图6-20所示。我连0都数不过来了！和这么多搜索结果去竞争关键字，是我们在推广过程中不可逾越的鸿沟。

图6-20　game关键字

所以，需要换个名字，让我们从小成长，找一个热度不是那么高的关键字作为项目名字。gridgame就是一个不错的选择，既能表现游戏的特征，从推广角度又没有特别强大的竞争对手，一下子压力全无，倍感轻松。Google搜索结果如图6-21所示。

图6-21　gridgame关键字

做好了各种准备工作，下面就是搞定gridgame包了！

6.5.2　gridgame包开发

按照5.2节中介绍的标准化的开发流程，进行gridgame包的开发。

本节的系统环境是：

·Windows 7 64bit

·R：3.1.1 x86_64-w64-mingw32/x64（64-bit）

·Rtools31.exe

·basic-miktex-2.9.5105.exe

由于之前gridgame包开发的游戏都是基于Windows平台的，而且暂时不打算支持Linux平台运行，所以我们选择的R包开发环境，也应该是Windows平台。后文中会介绍，为什么不支持Linux平台运行，R的版本最好要升级到3.1.1。（坑很多的，要一点一点地填！）

1.构建工程

为了减少工作量，提高开发效率，我将按照devtools包的开发流程进行操作。首先，打开一个项目目录，然后创建项目骨架。

~ R # 启动R程序
> setwd（"D：/workspace/R/app"） # 进入运行目录
> library（devtools） # 加载3个开发工具包
> library（roxygen2）
Loading required package： digest
> library（testthat）
> create（paste（getwd（），"/gridgame"，sep=""）） # 创建项目骨架
Creating package gridgame in /home/conan/R
No DESCRIPTION found. Creating default：
Package： gridgame
Title：
Description：
Version： 0.1
Authors@R： # getOptions（'devtools.desc.author'）
Depends： R （>= 3.0.1）
License： # getOptions（'devtools.desc.license'）
LazyData： true
> setwd（paste（getwd（），"/gridgame"，sep=""）） # 重置当前目录
> dir（full.names=TRUE） # 查看项目骨架生成的文件
[1] "./DESCRIPTION" "./man" "./R"

2.编写代码和文档

首先编辑DESCRIPTION文件，增加项目的描述信息。

~ vi /home/conan/R/gridgame/DESCRIPTION
Package： gridgame
Type： Package
Title： A game framework for R
Version： 0.0.1
Date： 2014-07-23
Authors@R： c（person（"Dan"， "Zhang"， email = "bsspirit@gmail.com"， role=c（"aut"， "cre"）））
Maintainer： Dan Zhang
Description： This package provides a general-purpose game framework for grid game in R.
The package includes 2 games about snake and 2048. You can run the function snake（）
or g2048（） to startup the game. These games are only running on Window platform.
Depends：
R （>= 3.0.1）
Imports：
methods
License： GPL-3
URL： http：//onbook.me/#/project/gridgame
BugReports： https：//github.com/bsspirit/gridgame/issues
OS_type： windows
Collate：
'game.R'
'2048.R'
'package.R'
'snake.R'

DESCRIPTION文件中，有两个地方需要注意。

（1）Imports：methods，由于我们用的是RC类型，系统默认会用methods包中的函数进行解析，必须在这里显示声明。

（2）OS_type：Windows，由于只仅支持Window系统运行，因此在后面上传到CRAN检查时，必须指明支持的系统。同时，也是由于增加了这个属性，再到Linux中执行R CMD check过程的时候会自动失败，因此要求我们只能在windows系统中进行打包和发布的操作。

然后，复制我们已经完成的3个R文件到/home/conan/R/gridgame/R目录下面。

~ ls -l
-rw-rw-r-- 1 conan conan 5030 7月 23 17：23 2048.R
-rw-rw-r-- 1 conan conan 2151 7月 23 17：18 game.R
-rw-rw-r-- 1 conan conan 5204 7月 23 17：23 snake.R

我们需要对代码进行再整理，都是检查失败错误。

·去掉2048.R和snake.R代码中source（）函数对game.R文件的引用。

·去掉代码中所有中文注释，只能是ASCII码支持的字符。

·在代码中增加Windows平台检查，非Windows则禁止运行，通过.Platform$OS.type==’windows’代码，判断运行时的系统环境。

·增加package.R文件，用于加载methods包的配置信息，#’@import methods。

·去掉代码中启动函数，启动交给用户来操作。

3.调试程序

在Windows系统开发环境中，通过load_all（）函数加载程序包，然后运行snake（）函数或者g2048（）函数，一切正常。

> load_all（getwd（）） # 加载程序包
Loading gridgame
> snake（） # 启动snake游戏
> g2048（） # 启动2048游戏

我们写的游戏程序，都是在Windows 7下开发的，运行一切正常，那么为什么不支持在Linux系统中运行呢？主要原因是Linux和Windows中有不同的图形设备输出。Windows系统中，输出设备是通过.net框架来支持的；而Linux系统中的输出设备是X11（）显示驱动支持，或者通过在Linux系统中加载第三方的TK设备支持，R语言通过tkrplot包来实现调用。

~ sudo apt-get install tk-dev
> install.packages（"tkrplot"）

Windows系统和Linux系统对于运行GUI程序是有区别的，无法统一用一套代码来完成。有人会说，每个地方都增加系统类型的判断条件就能实现了。

当然情况并不是这么简单，除了输出设备的问题以外，Linux上面还会遇到字体的问题，字库不全将导致字符加载失败的错误。下面的问题，Linux系统中没有helvetica的60号字体。

Error in text.default（0.5， 0.7， label = name， cex = 5） ：
X11 font -adobe-helvetica-%s-%s-*-*-%d-*-*-*-*-*-*-*， face 1 at size 60 could not be loaded

虽然在Linux Ubuntu环境中，我尝试了安装所有字体库，仍然无法解决大号字体的加载问题。所以，我决定暂时不支持Linux平台，等以后有时间再解决这个问题。

~ sudo apt-get install xfont-100dpi xfont-75dpi xfont-cyrillic xfont-*

4.单元测试

在inst/test目录下面，我们分别针对不同的文件，创建单元测试类。

·test-game.R，对game.R的函数进行单元测试。

·test-snake.R，对snake.R的函数进行单元测试。

·test-2048.R，对2048.R的函数进行单元测试。

以test-game.R为例，打开test-game.R文件。

~ vi inst/test/test-game.R
context（"game"）
test_that（"Initial the construct function of Game class"， {
name<-"R"
width<-height<-10
game<-Game$new（）
game$initFields（name=name，width=width，height=height）
expect_that（game$name，equals（name））
expect_that（game$width，equals（width））
expect_that（game$height，equals（height））
}）

执行单元测试代码。

> test（getwd（））
Testing gridgame
Loading gridgame
game ： ...

5.撰写文档

R包开发中最繁琐的一个过程，就是撰写LaTex格式的文档。幸好有人发明了roxygen2包，通过简单的注释规则来生成LaTex文档。

我们用roxygen2包来生成man/*.Rd的文档文件，对RC类型的程序，其实就可以偷点懒了，只是在类的定义上，增加注释就行了。RC类中方法的注释，就没强制的检查，多写少写就看开发者的心情了。如果是S3的编程方式或者纯函数式的包，那么写文档也是很辛苦的工作。另外，文件不能出现中文字符，不然check过程的时候，还是会有警告发生的。

以snake.R文件中注释为例，我们只写setRefClass的注释和snake<-function（）{}的注释就行了，Snake类的内部方法暂时就省略了。后面有时间我会再补充文档的，多写点文档没坏处。

~ vi snake.R
#' Snake game class
#' @include game.R
Snake<-setRefClass（"Snake"，contains="Game"，
...）
#' Snake game function
#'
#' @export
snake<-function（）{
game<-Snake$new（）
game$initFields（）
game$run（）
}

通过代码中的注释生成LaTex文件。

> document（getwd（））
Updating gridgame documentation
Loading gridgame
Writing G2048-class.Rd
Writing g2048.Rd
Writing Game-class.Rd
Writing Snake-class.Rd
Writing snake.Rd

打开snake.Rd文件，看看生成的内容。

~ vi man/snake.Rd
% Generated by roxygen2 （4.0.1）： do not edit by hand
\name{snake}
\alias{snake}
\title{Snake game function}
\usage{
snake（）
}
\description{
Snake game function
}

这一步的操作过程，其实也不是一帆风顺的。在引用roxygen2包的时候，我遇到了同样的问题。在Windows环境中，roxygen2包依赖于R 3.0.2以上的版本，R 3.0.1版本的R程序装不上roxygen2包。github有对这个强依赖问题的描述见https://github.com/klutometis/roxygen/issues/163。所以，文中建议在R 3.1.1的版本环境，是实践检验出来的。

6.程序检查

程序检查这一步其实是所有操作过程最容易出错的，也不一定能搞定。R的打包的检查真的很严格！

在Windows平台中开发R包，要额外装两个软件，即Rtools（http://cran.us.r-project.org/bin/windows/Rtools/）和MikTeX（http://www.miktex.org/download），不仅版本要和R语言环境匹配上，环境变量也要配置对。本节中Rtools版本为Rtools version 3.1.0.1942，MikTeX对应的版本为2.9.4533。MikTeX在调用过程中，还会遇到文件找不到，pdflatex.exe运行错误等问题。比如，其中的一个常见错误：

* checking PDF version of manual ... WARNING
LaTeX errors when creating PDF version.
This typically indicates Rd problems.
LaTeX errors found：！pdfTeX error： pdflatex.EXE （file ts1-zi4r）： Font ts1-zi4r at 540 not found
==> Fatal error occurred， no output PDF file produced！
* checking PDF version of manual without hyperrefs or index ... ERROR

解决方法是在命令行运行下面的命令。

~ updmap~ initexmf --update-fndb~ initexmf --edit-config-file updmap # 打开文件
Map zi4.map # 在文件中增加~ initexmf --mkmaps

最后，经过九九八十一难，终于修成正果，一切顺利地完成了！

> check（getwd（））
Updating gridgame documentation
Loading gridgame
Writing NAMESPACE
Writing G2048-class.Rd
Writing g2048.Rd
Writing Game-class.Rd
Writing Snake-class.Rd
Writing snake.Rd
"C：/PROGRA~1/R/R-30~1.3/bin/x64/R" --vanilla CMD build \
"D：\workspace\R\app\gridgame" --no-manual --no-resave-data
* checking for file 'D：\workspace\R\app\gridgame/DESCRIPTION' ... OK
* preparing 'gridgame'：
* checking DESCRIPTION meta-information ... OK
* checking for LF line-endings in source and make files
* checking for empty or unneeded directories
* building 'gridgame_0.0.1.tar.gz'
"C：/PROGRA~1/R/R-30~1.3/bin/x64/R" --vanilla CMD check \
"C：\Users\ADMINI~1\AppData\Local\Temp\RtmponOeAc/gridgame_0.0.1.tar.gz" \
--timings
* using log directory 'C：/Users/ADMINI~1/AppData/Local/Temp/RtmponOeAc/gridgame.Rcheck'
* using R version 3.0.3 （2014-03-06）
* using platform： x86_64-w64-mingw32 （64-bit）
* using session charset： ASCII
* checking for file 'gridgame/DESCRIPTION' ... OK
* checking extension type ... Package
* this is package 'gridgame' version '0.0.1'
* checking package namespace information ... OK
* checking package dependencies ... OK
* checking if this is a source package ... OK
* checking if there is a namespace ... OK
* checking for executable files ... OK
* checking for hidden files and directories ... OK
* checking for portable file names ... OK
* checking whether package 'gridgame' can be installed ... OK
* checking installed package size ... OK
* checking package directory ... OK
* checking DESCRIPTION meta-information ... OK
* checking top-level files ... OK
* checking for left-over files ... OK
* checking index information ... OK
* checking package subdirectories ... OK
* checking R files for non-ASCII characters ... OK
* checking R files for syntax errors ... OK
* checking whether the package can be loaded ... OK
* checking whether the package can be loaded with stated dependencies ... OK
* checking whether the package can be unloaded cleanly ... OK
* checking whether the namespace can be loaded with stated dependencies ... OK
* checking whether the namespace can be unloaded cleanly ... OK
* checking loading without being on the library search path ... OK
* checking dependencies in R code ... OK
* checking S3 generic/method consistency ... OK
* checking replacement functions ... OK
* checking foreign function calls ... OK
* checking R code for possible problems ... OK
* checking Rd files ... OK
* checking Rd metadata ... OK
* checking Rd cross-references ... OK
* checking for missing documentation entries ... OK
* checking for code/documentation mismatches ... OK
* checking Rd \usage sections ... OK
* checking Rd contents ... OK
* checking for unstated dependencies in examples ... OK
* checking examples ... OK
* checking PDF version of manual ... OK

在执行check过程中，你的项目里可能会有其他的文件，因而检查通不过。你可新建一个文件.Rbuildignore，通过这个文件进行配置，忽略不希望参与打包的文件。

~ vi .Rbuildignore
.gitignore
dist
^.*\.Rproj$
^\.Rproj\.user$
README*
NEWS*

跳过不希望参与打包的一些帮助文件，就能通过检查了。

7.程序打包

在检查通过以后，我们就可以自由地打包了，用build命令。有2种打包方式选择，即源代码打包和二进打包。默认是给源代码打包。

> build（）
"C：/PROGRA~1/R/R-30~1.3/bin/x64/R" --vanilla CMD build \
"D：\workspace\R\app\gridgame" --no-manual --no-resave-data
* checking for file 'D：\workspace\R\app\gridgame/DESCRIPTION' ... OK
* preparing 'gridgame'：
* checking DESCRIPTION meta-information ... OK
* checking for LF line-endings in source and make files
* checking for empty or unneeded directories
* building 'gridgame_0.0.2.tar.gz'
[1] "D：/workspace/R/app/gridgame_0.0.2.tar.gz"

如果用二进制打包，需再传一个binary的参数。

> build（binary=TRUE）
"C：/PROGRA~1/R/R-30~1.3/bin/x64/R" --vanilla CMD INSTALL \
"D：\workspace\R\app\gridgame" --build
* installing to library 'C：/Users/Administrator/AppData/Local/Temp/RtmpI3hhpp'
* installing *source* package 'gridgame' ...
** R
** inst
** preparing package for lazy loading
** help
*** installing help indices
** building package indices
** testing if installed package can be loaded
*** arch - i386
*** arch - x64
* MD5 sums
packaged installation of 'gridgame' as gridgame_0.0.2.zip
* DONE （gridgame）
[1] "D：/workspace/R/app/gridgame_0.0.2.zip"

这两个打包后的文件，都可以用来发布项目，用户下载后可以直接进行安装。

# 安装命令~ R CMD INSTALL gridgame_0.0.2.tar.gz
* installing to library 'C：/Users/Administrator/R/win-library/3.0'
* installing *source* package 'gridgame' ...
** R
** inst
** preparing package for lazy loading
** help
*** installing help indices
** building package indices
** testing if installed package can be loaded
*** arch - i386
*** arch - x64
* DONE （gridgame）

6.5.3　gridgame包发布

最后一步，就是把我们好不容易开发的包，发布到资源库。有4个平台可以发布我们做好的R包。

·Github：个人开源发布平台

·R-Forge：R-Forge发布平台

·RForge：RForge发布平台

·CRAN：R的官方发布平台

1.Github：个人的开源发布平台

在Github上发布是最容易的，只要把项目代码上传到Github就完成了，都不需要做check（）检查。基于Github发布，需要用到包管理工具devtools包，我把gridgame项目已上传到Github，项目地址是https://github.com/bsspirit/gridgame，用户可以通过下面两种方式，直接从Github安装gridgame项目。

方法一：使用devtools包，二进制安装。

library（devtools）
install_github（"gridgame"，"bsspirit"）

方法二：通过源代码安装。

git clone https：//github.com/bsspirit/gridgame.git
R CMD BUILD gridgame
R CMD INSTALL gridgame_*.tar.gz

2.R-Forge：R-Forge发布平台

在R-Forge（https://r-forge.r-project.org/）发布比较麻烦，需要先注册一个账号，https://r-forge.r-project.org/account/register.php，登陆后，再新建一个项目，需要等72小时审核才能通过。

在R-Forge中，gridgame项目管理界面截图，如图6-22所示。

然后，通过SVN把项目的源代码提交上去。如果我们用习惯了Git进行版本管理，再回过头来用SVN，感觉好老土啊！

在R-Forge平台上提交代码，并运行通过以后，会有项目介绍页http://gridgame.r-forge.r-project.org/，如图6-23所示，其他开发者会看到项目介绍，下载你的包。

图6-22　R-Forge平台

图6-23　R-Forge平台的girdgame项目

用户可以直接查看项目信息（http://gridgame.r-forge.r-project.org/），也可以在线查看项目源代码（https://r-forge.r-project.org/scm/viewvc.php/root=gridgame），R-Froge平台会每天自动打包一次。

3.RForge：RForge发布平台

此RForge（http://rforge.net/）非彼R-Froge，但是两个名字如此相似，第一次用的人肯定会混淆的。首先注册RForge账号，同时注册一个要发布的项目，如图6-24所示。gridgame项目，我已经上传到Github了，这边能直接导入Github项目，非常方便。

图6-24　RForge平台

通过RForge源下载gridgame包，可以直接用install.packages（）函数。

install.packages（'gridgame'， repos = 'http：//rforge.net'）

注　项目未发布成功，请先用Github的方案

4.CRAN发布：R的官方发布平台

在这4个发布平台中，CRAN是最全威的，因为它是官方的，当然，它也是最难发布的，有很严格的审查机制。CRAN发布条款可参见http://cran.r-project.org/web/packages/policies.html。我们读完政策后，通过http://cran.r-project.org/submit.html提交项目，大概要等待48小时审查。可能我这个包的问题比较严重，6个小时内有就了回复。

·第一次不合格：没有标出只支持Windows平台，对应DESCRIPTION文件中OS_type：Windows。（当然，他是不会告诉你怎么改的，自己用Google找吧。）

·第二次不合格：Linux平台R CMD check出错。（加了OS_type后，Linux执行当然会出错了，老外似乎也晕了。）

·第三次不合格：为什么Linux不能用，为什么用.Platform$OS.type的代码检查，getGraphicsEvent在没有GUI的环境中怎么办，文档不全，对game framework的定义不清楚。（笔者费了好大劲解释，把这几篇文章的设计理念，写了封总结的邮件。）

·第四次不合格：这次Uwe Ligges的态度很强硬，必须把Rd写完整，必须支持至少2个平台，必须对getGraphicsEvent进行检查，必须处理OS.type的代码问题，没有商量的余地，不搞定就不给发布。（我真是悲剧了，看来发布项目，又要延期了。）

下面是提交项目到CRAN的过程。

第一步：填写用户基本信息，并上传打好的tar.gz包，如图6-25所示。

第二步：核对DESCRIPTION文件中的描述，与网页自动解析的内容是否一致，如图6-26所示。

图6-25　CRAN发布第一步

图6-26　CRAN发布第二步

第三步：等待审核，如图6-27所示。

图6-27　CRAN发布第三步

第一次不合格，老外回复的邮件：

On 25/07/2014 04：24， Dan Zhang wrote：
> [This was generated from CRAN.R-project.org/submit.html]
>
> The following package was uploaded to CRAN：
> ===========================================
>
> Package Information：
> Package： gridgame
> Version： 0.0.1
> Title： A game framework for R
> Author（s）： Dan Zhang [aut， cre]
> Maintainer： Dan Zhang
> Depends： R （>= 3.0.1）
> Description： This package provides a general-purpose game framework for
'This package provides' is redundant.
> grid game in R. The package includes 2 games about snake and
> 2048. You can run the function snake（） or g2048（） to startup
> the game. These games are only running on Window platform.
Eh The CRAN policies do not allow such a package， and you have not
marked this as Windows-only.
> License： GPL-3
> Imports： methods
>
>
> The maintainer confirms that he or she
> has read and agrees to the CRAN policies.
>
> Submitter's comment： This package provides a general-purpose game
> framework for grid game in R. The package includes 2
> games about snake and 2048. You can run the function
> snake（） or g2048（） to startup the game. These games
> are only running on Window platform.
>
--
Brian D. Ripley， ripley@stats.ox.ac.uk
Professor of Applied Statistics， http：//www.stats.ox.ac.uk/~ripley/
University of Oxford， Tel： +44 1865 272861 （self）
1 South Parks Road， +44 1865 272866 （PA）
Oxford OX1 3TG， UK Fax： +44 1865 272595

经过多次的对决和修改，笔者多么想说“终于把包成功发布到了CRAN”，但是最后的结果是被要求继续修改，确实是折磨啊。如果gridgame包在CRAN发布成功，用户安装时就方便了，可以通过下面的代码（目前还在修改中）。

# 从CRAN下载gridgame包
install.packages（'gridgame'） # 未发布成功，请先用Github的方案
library（gridgame） # 加载gridgame包
snake（） # 启动贪食蛇游戏
g2048（） # 启动2048游戏

在CRAN上发布一个R包，真不是一件轻松的事情！坚持，修改，打磨，再坚持，虽然过程很痛苦，但是软件质量最终得到了保证，这就是CRAN严格审查的意义。希望准备在R领域深入研究的朋友们，都能完成在CRAN上发布自己的R包。

到这里为止，本书的正文部分就结束了，感谢你的阅读。希望这本书能让你更深入地了解R语言，掌握R语言的思维模式。另外，下一本书《R的极客理想——量化投资篇》将会为你介绍R语言在金融领域的应用，告诉读者如何让技术真正变成价值，让屌丝程序员也能逆袭。我很期待你能使用本书里学到的知识，做出不一样的应用。