• Posts tagged "R"
  • (Page 20)

Blog Archives

R语言构建websocket服务器

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

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

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

关于作者:

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

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

websockets-r

前言

R语言从一门统计语言,正向着工业化语言发展。不仅支持web的可视化,web的基本操作,还支持websocket。我们的互联网应用程序不用再绕道Rserve,直接通过websocket协议,就能实现与R语言的交互。

R语言正在发生着技术革命,更先进,更便捷….

目录

  1. websockets介绍
  2. websockets安装
  3. websockets的API介绍
  4. 快速启动websockets服务器demo
  5. R语言创建websocket服务器实例
  6. R语言创建websocket客户端连接
  7. 用浏览器HTML5原生API客户端连接

1. websockets介绍

Websocket协议是基于HTML5规范的,在浏览器上实现的客户端和服务器端通信协议。

Websocket有以下优势:

  • 显着降低网络开销。
  • 减少服务器的处理开销。
  • 简化Web客户端(推)的快速异步更新。
  • 简化服务器和客户端之间的耦合状态。

websockets包,是R语言的一个websocket接口的类库。通过websockets包,可以非常简单地使用R语言构建一个websocket服务器实例。同时,websockets包还提供客户端的API。

websockets包的发布页:http://cran.r-project.org/web/packages/websockets/index.html

2. websockets安装

系统环境:

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

注:经过测试websockets在win环境中,有各种的问题。请使用linux环境。

websockets安装,加载


~ R

> install.packages("websockets")
also installing the dependency ‘caTools’

trying URL 'http://mirror.bjtu.edu.cn/cran/bin/windows/contrib/3.0/caTools_1.16.zip'
Content type 'application/zip' length 227507 bytes (222 Kb)
opened URL
downloaded 222 Kb

trying URL 'http://mirror.bjtu.edu.cn/cran/bin/windows/contrib/3.0/websockets_1.1.7.zip'
Content type 'application/zip' length 272593 bytes (266 Kb)
opened URL
downloaded 266 Kb

package ‘caTools’ successfully unpacked and MD5 sums checked
package ‘websockets’ successfully unpacked and MD5 sums checked

> library(websockets)
'websockets'R3.0.2

websockets库依赖于caTools库,caTools是一个工具集,请参考文章:caTools一个奇特的工具集

补充:websockets包被移出CRAN。

websockets包在2014-03-02时,被移出了CRAN包,目前还不知道是什么原因。

原文网页地址 http://cran.r-project.org/web/packages/websockets/index.html


Package ‘websockets’ was removed from the CRAN repository.

Formerly available versions can be obtained from the archive.

Archived on 2014-03-02 at the request of the maintainer.

这样我们在安装websockets包的时候,通过install.packages()的命令就会出错误了。


> install.packages("websockets")
Installing package into ‘/home/conan/R/x86_64-pc-linux-gnu-library/3.0’
(as ‘lib’ is unspecified)
警告信息:
package ‘websockets’ is not available (for R version 3.0.1)

我们需要下载安装包,手动进行安装。


# 下载最新的websockets包
~ wget http://cran.r-project.org/src/contrib/Archive/websockets/websockets_1.1.7.tar.gz

# 在当前目录安装websockets
~  R CMD INSTALL websockets_1.1.7.tar.gz
* installing to library ‘/home/conan/R/x86_64-pc-linux-gnu-library/3.0’
ERROR: dependencies ‘caTools’, ‘digest’ are not available for package ‘websockets’
* removing ‘/home/conan/R/x86_64-pc-linux-gnu-library/3.0/websockets’

安装过程中出现错误,提示为缺少依赖包caTools, digest,所以我们需要先安装这两个依赖包。


# 启动R程序
~ R

# 安装依赖包
> install.packages("caTools")
> install.packages("digest")

# 回到命令行,再次安装websockets包,安装成功
~ R CMD INSTALL websockets_1.1.7.tar.gz
* installing to library ‘/home/conan/R/x86_64-pc-linux-gnu-library/3.0’
* installing *source* package ‘websockets’ ...
** 成功将‘websockets’程序包解包并MD5和检查
** libs
gcc -std=gnu99 -I/usr/share/R/include -DNDEBUG     -DLWS_NO_FORK -fpic  -O3 -pipe  -g  -c libsock.c -o libsock.o
gcc -std=gnu99 -shared -o websockets.so libsock.o -L/usr/lib/R/lib -lR
installing to /home/conan/R/x86_64-pc-linux-gnu-library/3.0/websockets/libs
** R
** demo
** inst
** preparing package for lazy loading
** help
*** installing help indices
** building package indices
** installing vignettes
   ‘websockets.Rnw’
** testing if installed package can be loaded
* DONE (websockets)

# 启动R程序
~ R

# 加载websockets包
> library(websockets)

通过手动的方式,我们就安装好了websockets包。

3. websockets的API介绍

  • create_server: 创建一个websocket服务器实例,并绑定端口
  • daemonize: 绑定websocket服务器实例守护进程,到R的控制台,不支持Windows
  • http_response: 发送HTTP Response请求到socket
  • http_vars: 解析HTTP GET/POST参数列表
  • service: 注册websocket实例的服务队列
  • set_callback: 在websocket实例中,定义R函数
  • static_file_service: 静态文件
  • static_text_service: 静态文本
  • websocket: 创建一个websocket客户端实例
  • websocket_broadcast: 向注册在同一个websocket服务器实例的客户端发广播
  • websocket_close: 关闭客户端连接
  • websocket_write: 通过websocket进行数据传输

4. 快速启动websockets服务器demo

websockets包,提供了一个demo。通过demo(websockets)函数,直接启动一个简单的websocket服务器。


~ R

> library(websockets)
'websockets'R3.0.2

> demo(websockets)

        demo(websockets)
        ---- ~~~~~~~~~~

Type     to start :

> # Simple example
> require(websockets)

> w = create_server()

> f = function(DATA, WS, ...)
+ {
+   cat("Receive callback\n")
+   D = ""
+   if(is.raw(DATA)) D = rawToChar(DATA)
+   websocket_write(DATA=paste("You sent",D,"\n",collapse=" "),WS=WS)
+ }

> set_callback('receive',f,w)

> cl = function(WS)
+ {
+   cat("Websocket client socket ",WS$socket," has closed.\n")
+ }

> set_callback('closed',cl,w)

> es = function(WS)
+ {
+   cat("Websocket client socket ",WS$socket," has been established.\n")
+ }

> set_callback('established',es,w)

> cat("Direct your web browser to http://localhost:7681\n")
Direct your web browser to http://localhost:7681

> while(TRUE) service(w)

打开浏览器:http://192.168.1.201:7681

websockets-demo

服务器日志:


Websocket client socket  20  has closed.
Websocket client socket  8  has been established.
Websocket client socket  21  has closed.

查看服务器端:


~ netstat -nltp|grep r

Proto Recv-Q Send-Q Local Address           Foreign Address         State       PID/Program name
tcp        0      0 0.0.0.0:7681            0.0.0.0:*               LISTEN      2231/rsession

5. R语言创建websocket服务器实例

  • 1. 加载类库
  • 2. 初始化create_server()
  • 3. 定义回调函数
  • 4. 定义事件服务

~ R

#加载类库
library(websockets)

#浏览器的HTTP输出
text = "<html><body>
<h1>Hello world</h1>
</body></html>"

## 创建服务实例
w = create_server(port=7681,webpage=static_text_service(text))

## 监听receive
recv = function(DATA, WS, ...){
  cat("Receive callback\n")
  D = ""
  if(is.raw(DATA)){D = rawToChar(DATA)}

  cat("Callback:You sent",D,"\n")
  websocket_write(DATA=paste("You sent",D,"\n",collapse=" "),WS=WS)
}
set_callback('receive',recv,w)

## 监听closed
cl = function(WS){
  cat("Websocket client socket ",WS$socket," has closed.\n")
}
set_callback('closed',cl,w)

## established
es = function(WS){
  cat("Websocket client socket ",WS$socket," has been established.\n")
}
set_callback('established',es,w)

#对所有的连接进行监听
while(TRUE) service(w)

6. R语言创建websocket客户端连接

在Linux环境中,新建一个文件:client.r


~ vi client.r

#加载类库
library(websockets)

#创建客户端实例
client = websocket("ws://192.168.1.201",port=7681)

#监听receive
rece<-function(DATA, WS, HEADER) {   D=''   if(is.raw(DATA)){     cat("raw data")     D = rawToChar(DATA)   }   cat("==>",D,"\n")
}
set_callback("receive",rece, client)

#向服务器发请求
websocket_write("2222", client)

#输出服务器的返回值
service(client)

#关闭连接
websocket_close(client)

运行程序:


> library(websockets)
>
> client = websocket("ws://192.168.1.201",port=7681)
>
> # receive
> rece<-function(DATA, WS, HEADER) { +   D='' +   if(is.raw(DATA)){ +     cat("raw data") +     D = rawToChar(DATA) +   } +   cat("==>",D,"\n")
+ }
> set_callback("receive",rece, client)
> websocket_write("2222", client)
[1] 1
>
> service(client)
raw data==> You sent 2222

>
> websocket_close(client)
Client socket 3  was closed.

7. 用浏览器HTML5原生API客户端连接

打开浏览器:http://192.168.1.201:7681/

websockets-html5-js

我们可以通过浏览器console写js的代码,实现和websocket服务器的通信。

原生的HTML5程序


var ws = new WebSocket("ws://192.168.1.201:7681");
ws.onopen = function(){
console.log("connecting");
};
ws.onmessage = function(message){
console.log(message.data);
console.log(message);
};
function postToServer(msg){
ws.send(msg);
}
function closeConnect(){
ws.close();
console.log("closed");
}

postToServer('browser');
closeConnect();

我们这样就完成了,R语言构建的websocket服务器测试。又给R语言与其他语言通信打开了一条便利的通道。

关于websocket的其他语言实现,请参考文章:

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

打赏作者

formatR代码自动化排版

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

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

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

关于作者:

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

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

r-formatR

前言

程序员最痛苦的事情,不是每天加班写程序,而是每天加班读懂别人写的程序。

大多数程序员写的代码都没有考虑,如何让别人看着更方便!最后,实在忍受不了看其他人的丑陋代码时,有人开始制定代码编程规范;又有人实现代码的自动化排版工具。formatR就是这样的一个R语言自动化排版的工具。

目录

  1. formatR介绍
  2. formatR安装
  3. formatR的API介绍
  4. formatR的使用
  5. formatR的源代码解析

1. formatR介绍

formatR包是一个实用的包,提供了R代码格式化功能,自动设置空格、缩进、换行等代码格式,让代码看起来更友好。

formatR的发布页:http://yihui.name/formatR/

2. formatR安装

系统环境

  • Win7 64bit
  • R: 3.0.1 x86_64-w64-mingw32/x64 b4bit

formatR安装


~ R

> install.packages("formatR")
trying URL 'http://mirror.bjtu.edu.cn/cran/bin/windows/contrib/3.0/formatR_0.10.zip'
Content type 'application/zip' length 49263 bytes (48 Kb)
opened URL
downloaded 48 Kb

package ‘formatR’ successfully unpacked and MD5 sums checked

formatR加载

library(formatR)

3. formatR的API介绍

  • 1). tidy.source: 对代码进行格式化
  • 2). tidy.eval: 输出格式化的R代码和运行结果
  • 3). usage: 格式化函数定义,并按指定宽度输出
  • 4). tidy.gui: 一个GUI工具,支持编辑并格式化R代码
  • 5). tidy.dir: 对某个目录下,所有R脚本进行格式化

3. formatR的使用

  • 1). tidy.source:以字符串形式,对代码格式化
  • 2). tidy.source:以文件形式,对代码格式化
  • 3). 格式化并输出R脚本文件
  • 4). tidy.eval: 输出格式化的R代码和运行结果
  • 5). usage: 格式化函数定义,并按指定宽度输出
  • 6). tidy.gui: GUI工具,编辑并格式化R代码
  • 7). tidy.dir: 对目录下,所有R脚本进行格式化

1). 以字符串形式,对代码格式化


> tidy.source(text = c("{if(TRUE)1 else 2; if(FALSE){1+1", "## comments", "} else 2}"))
{
    if (TRUE) 
        1 else 2
    if (FALSE) {
        1 + 1
        ## comments
    } else 2
} 

2). 以文件形式,对代码格式化


> messy = system.file("format", "messy.R", package = "formatR")
> messy
[1] "C:/Program Files/R/R-3.0.1/library/formatR/format/messy.R"

原始代码输出


> src = readLines(messy)
> cat(src,sep="\n")
    # a single line of comments is preserved
1+1

if(TRUE){
x=1  # inline comments
}else{
x=2;print('Oh no... ask the right bracket to go away!')}
1*3 # one space before this comment will become two!
2+2+2    # 'short comments'

lm(y~x1+x2, data=data.frame(y=rnorm(100),x1=rnorm(100),x2=rnorm(100)))  ### only 'single quotes' are allowed in comments
1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1  ## comments after a long line
'a character string with \t in it'

## here is a long long long long long long long long long long long long long long long long long long long long comment

格式化后的代码输出


> tidy.source(messy)
# a single line of comments is preserved
1 + 1

if (TRUE) {
    x = 1  # inline comments
} else {
    x = 2
    print("Oh no... ask the right bracket to go away!")
}
1 * 3  # one space before this comment will become two!
2 + 2 + 2  # 'short comments'

lm(y ~ x1 + x2, data = data.frame(y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100)))  ### only 'single quotes' are allowed in comments
1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1  ## comments after a long line
"a character string with \t in it"

## here is a long long long long long long long long long long long long long long long long
## long long long long comment 

3). 格式化并输出R脚本文件

新建R脚本文件:demo.r


~ vi demo.r

a<-1+1;a;matrix(rnorm(10),5);
if(a>2) { b=c('11',832);"#a>2";} else print('a is invalid!!')

格式化demo.r


> x = "demo.r"
> tidy.source(x)
a <- 1 + 1
a
matrix(rnorm(10), 5)
if (a > 2) {
    b = c("11", 832)
    "#a>2"
} else print("a is invalid!!") 

输出格式化结果到文件:demo2.r


> f="demo2.r"
> tidy.source(x, keep.blank.line = TRUE, file = f)
> file.show(f)

formatR-file

4). tidy.eval: 输出格式化的R代码和运行结果

以字符串形式,执行R脚本


> tidy.eval(text = c("a<-1+1;a", "matrix(rnorm(10),5)"))
a <- 1 + 1
a
## [1] 2

matrix(rnorm(10), 5)
## [,1] [,2]
## [1,] 0.65050729 0.1725221
## [2,] 0.05174598 0.3434398
## [3,] -0.91056310 0.1138733
## [4,] 0.18131010 -0.7286614
## [5,] 0.40811952 1.8288346

5). usage: 格式化函数定义,并按指定宽度输出

> var
function (x, y = NULL, na.rm = FALSE, use)
{
if (missing(use))
use <- if (na.rm)
"na.or.complete"
else "everything"
na.method <- pmatch(use, c("all.obs", "complete.obs", "pairwise.complete.obs",
"everything", "na.or.complete"))
if (is.na(na.method))
stop("invalid 'use' argument")
if (is.data.frame(x))
x <- as.matrix(x)
else stopifnot(is.atomic(x))
if (is.data.frame(y))
y <- as.matrix(y)
else stopifnot(is.atomic(y))
.Call(C_cov, x, y, na.method, FALSE)
}
<bytecode: 0x0000000008fad030>
<environment: namespace:stats>

> usage(var)
var(x, y = NULL, na.rm = FALSE, use)

usage函数,只输出函数的定义。


> usage(lm,width=30)
lm(formula, data, subset, weights, 
    na.action, method = "qr", model = TRUE, 
    x = FALSE, y = FALSE, qr = TRUE, 
    singular.ok = TRUE, contrasts = NULL, 
    offset, ...)

usage的width参数,控制函数的显示宽度。

6). tidy.gui: GUI工具,编辑并格式化R代码

安装gWidgetsRGtk2库


> install.packages("gWidgetsRGtk2")
also installing the dependencies ‘RGtk2’, ‘gWidgets’

trying URL 'http://mirror.bjtu.edu.cn/cran/bin/windows/contrib/3.0/RGtk2_2.20.25.zip'
Content type 'application/zip' length 13646817 bytes (13.0 Mb)
opened URL
downloaded 13.0 Mb

trying URL 'http://mirror.bjtu.edu.cn/cran/bin/windows/contrib/3.0/gWidgets_0.0-52.zip'
Content type 'application/zip' length 1212449 bytes (1.2 Mb)
opened URL
downloaded 1.2 Mb

trying URL 'http://mirror.bjtu.edu.cn/cran/bin/windows/contrib/3.0/gWidgetsRGtk2_0.0-82.zip'
Content type 'application/zip' length 787592 bytes (769 Kb)
opened URL
downloaded 769 Kb

package ‘RGtk2’ successfully unpacked and MD5 sums checked
package ‘gWidgets’ successfully unpacked and MD5 sums checked
package ‘gWidgetsRGtk2’ successfully unpacked and MD5 sums checked

打开GUI控制台


> library("gWidgetsRGtk2")
> g = tidy.gui()

我们输入一段不太好看的代码:

formatR-gui

点击“转换”

formatR-gui-2

在GUI的编辑器中,R语言的代码被格式化了!

7). tidy.dir: 对dir目录下,所有R脚本进行格式化

新建目录:dir
新建两个R脚本文件:dir.r, dir2.r


~ mkdir dir

~ vi dir.r
a<-1+1;a;matrix(rnorm(10),5);

~ vi dir2.r
if(a>2) { b=c('11',832);"#a>2";} else print('a is invalid!!')

执行tidy.dir


> tidy.dir(path="dir")
tidying dir/dir.r
tidying dir/dir2.r

分别查看dir.r和dir2.r


~ vi dir.r
a <- 1 + 1
a
matrix(rnorm(10), 5) 

~ vi dir2.r
if (a > 2) {
    b = c("11", 832)
    "#a>2"
} else print("a is invalid!!") 

我们发现不规则的代码,已经被格式化了!!

5. formatR的源代码解析

通过上面的使用,我们不难发现formatR包的核心函数,就是tidy.source函数,从github上面找到源代码:https://github.com/yihui/formatR/blob/master/R/tidy.R

我将在代码中增加注释:


tidy.source = function(
  source = 'clipboard', keep.comment = getOption('keep.comment', TRUE),
  keep.blank.line = getOption('keep.blank.line', TRUE),
  replace.assign = getOption('replace.assign', FALSE),
  left.brace.newline = getOption('left.brace.newline', FALSE),
  reindent.spaces = getOption('reindent.spaces', 4),
  output = TRUE, text = NULL,
  width.cutoff = getOption('width'), ...
) {

  ## 判断输入来源为剪贴板
  if (is.null(text)) {
    if (source == 'clipboard' && Sys.info()['sysname'] == 'Darwin') {
      source = pipe('pbpaste')
    }
  } else {  ## 判断输入来源为字符串
    source = textConnection(text); on.exit(close(source))
  }
  
  ## 按行读取来源数据
  text = readLines(source, warn = FALSE)
  
  ## 大小处理
  if (length(text) == 0L || all(grepl('^\\s*$', text))) {
    if (output) cat('\n', ...)
    return(list(text.tidy = text, text.mask = text))
  }

  ## 空行处理
  if (keep.blank.line && R3) {
    one = paste(text, collapse = '\n') # record how many line breaks before/after
    n1 = attr(regexpr('^\n*', one), 'match.length')
    n2 = attr(regexpr('\n*$', one), 'match.length')
  }

  ## 注释处理
  if (keep.comment) text = mask_comments(text, width.cutoff, keep.blank.line)

  ## 把输入的R代码,先转成表达式,再转回字符串。用来实现对每个语句的截取。
  text.mask = tidy_block(text, width.cutoff, replace.assign && length(grep('=', text)))

  ## 对注释排版
  text.tidy = if (keep.comment) unmask.source(text.mask) else text.mask

  ## 重新定位缩进
  text.tidy = reindent_lines(text.tidy, reindent.spaces)

  ## 扩号换行
  if (left.brace.newline) text.tidy = move_leftbrace(text.tidy)
  
  ## 增加首尾空行
  if (keep.blank.line && R3) text.tidy = c(rep('', n1), text.tidy, rep('', n2))
  
  ## 在console打印格式化后的结果
  if (output) cat(paste(text.tidy, collapse = '\n'), '\n', ...)

  ## 返回,但不打印结果
  invisible(list(text.tidy = text.tidy, text.mask = text.mask))
}

Bug: 没有对”->”进行处理

在读源代码的过程中,发现有一个小问题,没有对”->”进行处理,已经给作者提bug了。
https://github.com/yihui/formatR/issues/31

bug测试代码:


> c('11',832)->x2
> x2
[1] "11"  "832"

> tidy.source(text="c('11',832)->x2")
c("11", 832) <- x2 

> tidy.eval(text="c('11',832)->x2")
c("11", 832) <- x2
Error in eval(expr, envir, enclos) : object 'x2' not found

BUG已修复:
作者回复:这个问题已经在R 3.0.2中修正了。


> formatR::tidy.source(text="c('11',832)->x2")
x2 <- c("11", 832) 
> sessionInfo()
R version 3.0.2 (2013-09-25)
Platform: x86_64-pc-linux-gnu (64-bit)

locale:
 [1] LC_CTYPE=en_US.UTF-8       LC_NUMERIC=C              
 [3] LC_TIME=en_US.UTF-8        LC_COLLATE=en_US.UTF-8    
 [5] LC_MONETARY=en_US.UTF-8    LC_MESSAGES=en_US.UTF-8   
 [7] LC_PAPER=en_US.UTF-8       LC_NAME=C                 
 [9] LC_ADDRESS=C               LC_TELEPHONE=C            
[11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C       

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods   base     

loaded via a namespace (and not attached):
[1] formatR_0.10.3

formatR包提供的功能非常实用,特别是读别人写的不规范的代码的时候。建议各IDE厂商能把formatR,作为标准的格式化工具直接嵌入编辑器的工具里面。让我们把读别人的代码,也变成一件快乐的事情吧。

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

打赏作者

ChinaHadoop大会 2103: R语言为Hadoop注入统计血脉

跨界知识聚会系列文章,“知识是用来分享和传承的”,各种会议、论坛、沙龙都是分享知识的绝佳场所。我也有幸作为演讲嘉宾参加了一些国内的大型会议,向大家展示我所做的一些成果。从听众到演讲感觉是不一样的,把知识分享出来,你才能收获更多。

关于作者

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

转载请注明出处:
http://blog.fens.me/hadoop-china-rhadoop-2013/

rhadoop-chinahadoop

前言

今天有幸在2013年ChinaHadoop大会发言,为R语言推广做出一点点贡献,自己感觉非常的激动。自学习R语言以来,跨学科的思维模式,每天都在扩充自己的视野!“唯有跳出IT的圈子,才能体会IT正在改变着世界”。

以计算机技术和统计为工具,再结合行业知识,必将成为未来“数据掘金”的原动力!抓住时代的机会,是80后崛起的时候了!

目录

  1. 主题内容介绍
  2. 活动照片

1. 主题内容介绍

ChinaHadoop的大会主页:http://www.chinahadoop.com/

R语言为Hadoop注入统计血脉:PPT下载

  • 1). 主题:R语言为Hadoop注入统计血脉
  • 2). RHadoop基础程序
  • 3). 分步式协同过滤ItemCF算法介绍
  • 4). ItemCF算法:R本地程序实现
  • 5). ItemCF算法:RHadoop实现
  • 6). ItemCF算法:Java Hadoop MapReduce实现
  • 7). ItemCF算法:Mahout 实现
  • 8). 推荐结果,数据可视化

1). 主题:R语言为Hadoop注入统计血脉
主要内容:R语言为Hadoop注入统计血脉

2). RHadoop基础程序

主要内容:RHadoop实践系列之二:RHadoop安装与使用

源代码


#hdfs
library(rhdfs)
hdfs.init()
hdfs.ls("/user/")
hdfs.cat("/user/hdfs/o_t_account/part-m-00000")

#rmr
library(rmr2)
small.ints <- 1:10
sapply(small.ints, function(x) x^2)

small.ints <- to.dfs(keyval(1,1:10))
from.dfs(small.ints)

output<-mapreduce(input = small.ints, map = function(k, v) cbind(v, v^2))
from.dfs(output)

#rmr-wordcount
input<-"/user/hdfs/o_t_account/"
wordcount = function(input, output = NULL, pattern = ","){
  
  wc.map = function(., lines) {
    keyval(unlist( strsplit( x = lines,split = pattern)),1)
  }
  
  wc.reduce =function(word, counts ) {
    keyval(word, sum(counts))
  }         
  
  mapreduce(input = input ,output = output, input.format = "text",
            map = wc.map, reduce = wc.reduce,combine = TRUE)
}
output<-wordcount(input)
from.dfs(output)

3). 分步式协同过滤ItemCF算法介绍
主要内容:RHadoop实践系列之三 R实现MapReduce的协同过滤算法

aglorithm_2

4). ItemCF算法:R本地程序实现

主要内容:RHadoop实践系列之三 R实现MapReduce的协同过滤算法

源代码:


library(plyr)

#读取数据集
train<-read.csv(file="small.csv",header=FALSE)
names(train)<-c("user","item","pref") 

#计算用户列表
usersUnique<-function(){
  users<-unique(train$user)
  users[order(users)]
}

#计算商品列表方法
itemsUnique<-function(){
  items<-unique(train$item)
  items[order(items)]
}

# 用户列表
users<-usersUnique() 
users

# 商品列表
items<-itemsUnique() 
items

#建立商品列表索引
index<-function(x) which(items %in% x)
data<-ddply(train,.(user,item,pref),summarize,idx=index(item)) 
data

#同现矩阵
cooccurrence<-function(data){
  n<-length(items)
  co<-matrix(rep(0,n*n),nrow=n)
  for(u in users){
    idx<-index(data$item[which(data$user==u)])
    m<-merge(idx,idx)
    for(i in 1:nrow(m)){
      co[m$x[i],m$y[i]]=co[m$x[i],m$y[i]]+1
    }
  }
  return(co)
}


#推荐算法
recommend<-function(udata=udata,co=coMatrix,num=0){
  n<-length(items)
  
  # all of pref
  pref<-rep(0,n)
  pref[udata$idx]<-udata$pref
  
  # 用户评分矩阵
  userx<-matrix(pref,nrow=n)
  
  # 同现矩阵*评分矩阵
  r<-co %*% userx
  
  # 推荐结果排序
  r[udata$idx]<-0
  idx<-order(r,decreasing=TRUE)
  topn<-data.frame(user=rep(udata$user[1],length(idx)),item=items[idx],val=r[idx])
  topn<-topn[which(topn$val>0),]
  
  # 推荐结果取前num个
  if(num>0){
    topn<-head(topn,num)
  }
  
  #返回结果
  return(topn)
}

co<-cooccurrence(data) 
co


#计算推荐结果
recommendation<-data.frame()
for(i in 1:length(users)){
  udata<-data[which(data$user==users[i]),]
  recommendation<-rbind(recommendation,recommend(udata,co,0)) 
} 

recommendation

5). ItemCF算法:RHadoop实现

主要内容:RHadoop实践系列之三 R实现MapReduce的协同过滤算法

源代码:


#加载rmr2包
library(rmr2)

#输入数据文件
train<-read.csv(file="small.csv",header=FALSE)
names(train)<-c("user","item","pref")

#把数据集存入HDFS
train.hdfs = to.dfs(keyval(train$user,train))
from.dfs(train.hdfs)

#STEP 1, 建立物品的同现矩阵
# 1) 按用户分组,得到所有物品出现的组合列表。
train.mr<-mapreduce(
  train.hdfs, 
  map = function(k, v) {
    keyval(k,v$item)
  }
  ,reduce=function(k,v){
    m<-merge(v,v)
    keyval(m$x,m$y)
  }
)
from.dfs(train.mr)

# 2) 对物品组合列表进行计数,建立物品的同现矩阵
step2.mr<-mapreduce(
  train.mr,
  map = function(k, v) {
    d<-data.frame(k,v)
    d2<-ddply(d,.(k,v),count)
    
    key<-d2$k
    val<-d2
    keyval(key,val)
  }
)
from.dfs(step2.mr)

# 2. 建立用户对物品的评分矩阵
train2.mr<-mapreduce(
  train.hdfs, 
  map = function(k, v) {
    df<-v
    key<-df$item
    val<-data.frame(item=df$item,user=df$user,pref=df$pref)
    keyval(key,val)
  }
)
from.dfs(train2.mr)

#3. 合并同现矩阵 和 评分矩阵
eq.hdfs<-equijoin(
  left.input=step2.mr, 
  right.input=train2.mr,
  map.left=function(k,v){
    keyval(k,v)
  },
  map.right=function(k,v){
    keyval(k,v)
  },
  outer = c("left")
)
from.dfs(eq.hdfs)


#4. 计算推荐结果列表
cal.mr<-mapreduce(
  input=eq.hdfs,
  map=function(k,v){
    val<-v
    na<-is.na(v$user.r)
    if(length(which(na))>0) val<-v[-which(is.na(v$user.r)),]
    keyval(val$k.l,val)
  }
  ,reduce=function(k,v){
    val<-ddply(v,.(k.l,v.l,user.r),summarize,v=freq.l*pref.r)
    keyval(val$k.l,val)
  }
)
from.dfs(cal.mr)


#5. 按输入格式得到推荐评分列表
result.mr<-mapreduce(
  input=cal.mr,
  map=function(k,v){
    keyval(v$user.r,v)
  }
  ,reduce=function(k,v){
    val<-ddply(v,.(user.r,v.l),summarize,v=sum(v))
    val2<-val[order(val$v,decreasing=TRUE),]
    names(val2)<-c("user","item","pref")
    keyval(val2$user,val2)
  }
)
from.dfs(result.mr)

6). ItemCF算法:Java Hadoop MapReduce实现

主要内容:用Hadoop构建电影推荐系统

源代码:https://github.com/bsspirit/maven_hadoop_template/releases/tag/recommend

7). ItemCF算法:Mahout 实现

主要内容:Mahout分步式程序开发 基于物品的协同过滤ItemCF

源代码: https://github.com/bsspirit/maven_mahout_template/tree/mahout-0.8

8). 推荐结果,数据可视化

数据集:small.csv


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.0
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

结果集: result.csv


1,104,33.5
1,106,18
1,105,15.5
1,107,5
2,106,20.5
2,105,15.5
2,107,4
3,103,24.5
3,102,18.5
3,106,16.5
4,102,37
4,105,26
4,107,9.5
5,107,11.5

R语言Socail Graph可视化


library(igraph)

train<-read.csv(file="small.csv",header=FALSE)

drawGraph<-function(data){
  names(data)<-c("from","to","f") 
  g <- graph.data.frame(data, directed=TRUE)
  V(g)$label <- V(g)$name
  V(g)$size <- 25
  V(g)$color <- c(rep("green",5),rep("red",7))
  V(g)$shape <- c(rep("rectangle",5),rep("circle",7))
  E(g)$color <- grey(0.5)
  E(g)$weight<-data$f
  E(g)$width<-scale(E(g)$weight,scale=TRUE)+2
  g2 <- simplify(g)
  plot(g2,edge.label=E(g)$weight,edge.width=E(g)$width,layout=layout.circle)
}

#small
drawGraph(train)

src_graph


#recommandation
recommendation<-read.csv(file="result.csv",header=FALSE)
drawGraph(recommendation)

recommand_graph

2. 活动照片

chinahadoop-1

chinahadoop-2

chinaHadoop2013

转载请注明出处:
http://blog.fens.me/hadoop-china-rhadoop-2013/

打赏作者

R语言性能监控工具Rprof

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

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

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

关于作者:

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

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

rprof-r

前言

随着R语言使用越来越深入,R语言的计算性能问题越来越突显。如何能清楚地了解一个算法对CPU的耗时,将成为性能优化的关键因素。

R的基础库提供性能监控的函数Rprof。

目录

  1. Rprof介绍
  2. Rprof的函数定义
  3. Rprof程序使用1: 股票数据分析案例
  4. Rprof程序使用2: 数据下载案例
  5. 用profr可视化性能指标
  6. Rprof的命令行使用

1. Rprof函数介绍

Rprof函数,是R语言核心包自带的一个性能数据日志函数,可以打印出函数的调用关系和CPU耗时的数据。再通过summaryRprof函数,分析Rprof生成的日志数据,获得性能报告。再通过profr库的plot函数,对报告进行可视化。

2. Rprof的函数定义

系统环境

  • Win7 64bit
  • R: 3.0.1 x86_64-w64-mingw32/x64 b4bit

Rprof函数在基础包utils中定义,所以就不用安装,直接可以使用。

查看Rprof的函数定义。


~ R

> Rprof
function (filename = "Rprof.out", append = FALSE, interval = 0.02,
memory.profiling = FALSE, gc.profiling = FALSE, line.profiling = FALSE,
numfiles = 100L, bufsize = 10000L)
{
if (is.null(filename))
filename <- ""
invisible(.External(C_Rprof, filename, append, interval,
memory.profiling, gc.profiling, line.profiling, numfiles,
bufsize))
}
<bytecode: 0x000000000d8efda8>

Rprof函数,用来生成日志文件,通常我们指需要指定filename就可以了。

3. Rprof程序使用: 股票数据分析案例

取股票数据作为测试数据集,000000_0.txt文件:1.38 MB (1,452,409 字节)

关于数据的业务含义,请参考文章:用RHive从历史数据中提取逆回购信息


> bidpx1<-read.csv(file="000000_0.txt",header=FALSE)
> names(bidpx1)<-c("tradedate","tradetime","securityid","bidpx1","bidsize1","offerpx1","offersize1")
> bidpx1$securityid<-as.factor(bidpx1$securityid)

> head(bidpx1)
  tradedate tradetime securityid bidpx1 bidsize1 offerpx1 offersize1
1  20130724    145004     131810  2.620     6960    2.630      13000
2  20130724    145101     131810  2.860    13880    2.890       6270
3  20130724    145128     131810  2.850   327400    2.851       1500
4  20130724    145143     131810  2.603    44630    2.800      10650
5  20130724    144831     131810  2.890    11400    3.000      77990
6  20130724    145222     131810  2.600  1071370    2.601      35750

> object.size(bidpx1)
1299920 bytes

字段解释

  • tradedate: 交易日期
  • tradetime: 交易时间
  • securityid: 股票ID
  • bidpx1: 买一价
  • bidsize1: 买一量
  • offerpx1: 卖一价
  • offersize1: 卖一量

计算任务:以securityid分组,计算每小时的买一价的平均值和买一总交易量


> library(plyr)

> fun1<-function(){
  datehour<-paste(bidpx1$tradedate,substr(bidpx1$tradetime,1,2),sep="")
  df<-cbind(datehour,bidpx1[,3:5])
  ddply(bidpx1,.(securityid,datehour),summarize,price=mean(bidpx1),size=sum(bidsize1))
}

> head(fun1())
  securityid   datehour    price      size
1     131810 2013072210 3.445549 189670150
2     131810 2013072211 3.437179 131948670
3     131810 2013072212 3.421000       920
4     131810 2013072213 3.509442 299554430
5     131810 2013072214 3.578667 195130420
6     131810 2013072215 1.833000    718940

以system.time函数查看fun1运行时间


> system.time(fun1())
用户 系统 流逝 
0.08 0.00 0.07
 
> system.time(fun1())
用户 系统 流逝 
0.06 0.00 0.06 

用Rprof记录统计数据


> file<-"fun1_rprof.out"
> Rprof(file)
> fun1()
> Rprof(NULL)

查看生成的文件:fun1_rprof.out


~ vi fun1_rprof.out

sample.interval=20000
"substr" "paste" "fun1" 
"paste" "fun1" 
"structure" "splitter_d" "ddply" "fun1" 
".fun" "" ".Call" "loop_apply" "llply" "ldply" "ddply" "fun1" 
".fun" "" ".Call" "loop_apply" "llply" "ldply" "ddply" "fun1" 
".fun" "" ".Call" "loop_apply" "llply" "ldply" "ddply" "fun1" 
"[[" "rbind.fill" "list_to_dataframe" "ldply" "ddply" "fun1" 

查看统计报告


> summaryRprof(file)
$by.self
            self.time self.pct total.time total.pct
".fun"           0.06    42.86       0.06     42.86
"paste"          0.02    14.29       0.04     28.57
"[["             0.02    14.29       0.02     14.29
"structure"      0.02    14.29       0.02     14.29
"substr"         0.02    14.29       0.02     14.29

$by.total
                    total.time total.pct self.time self.pct
"fun1"                    0.14    100.00      0.00     0.00
"ddply"                   0.10     71.43      0.00     0.00
"ldply"                   0.08     57.14      0.00     0.00
".fun"                    0.06     42.86      0.06    42.86
".Call"                   0.06     42.86      0.00     0.00
""             0.06     42.86      0.00     0.00
"llply"                   0.06     42.86      0.00     0.00
"loop_apply"              0.06     42.86      0.00     0.00
"paste"                   0.04     28.57      0.02    14.29
"[["                      0.02     14.29      0.02    14.29
"structure"               0.02     14.29      0.02    14.29
"substr"                  0.02     14.29      0.02    14.29
"list_to_dataframe"       0.02     14.29      0.00     0.00
"rbind.fill"              0.02     14.29      0.00     0.00
"splitter_d"              0.02     14.29      0.00     0.00

$sample.interval
[1] 0.02

$sampling.time
[1] 0.14
  • $by.self:当前函数的耗时情况
  • $by.total:整体函数调用的耗时情况

时间主要花在paste:0.02, ddply:0.06。

4. Rprof程序使用: 数据下载案例


> install.packages("stockPortfolio")
trying URL 'http://mirror.bjtu.edu.cn/cran/bin/windows/contrib/3.0/stockPortfolio_1.2.zip'
Content type 'application/zip' length 114669 bytes (111 Kb)
opened URL
downloaded 111 Kb

package ‘stockPortfolio’ successfully unpacked and MD5 sums checked

The downloaded binary packages are in
	C:\Users\Administrator\AppData\Local\Temp\RtmporLw4l\downloaded_packages
> library(stockPortfolio)
> fileName <- "Rprof2.log"
> Rprof(fileName)
> gr <- getReturns(c("GOOG", "MSFT", "IBM"), freq="week")
> Rprof(NULL)
> summaryRprof(fileName)$by.total[1:8,]
                    total.time total.pct self.time self.pct
"getReturns"              6.76    100.00      0.00     0.00
"read.delim"              6.66     98.52      0.00     0.00
"read.table"              6.66     98.52      0.00     0.00
"scan"                    4.64     68.64      4.64    68.64
"file"                    2.02     29.88      2.02    29.88
"as.Date"                 0.08      1.18      0.02     0.30
"strptime"                0.06      0.89      0.06     0.89
"as.Date.character"       0.06      0.89      0.00     0.00

时间主要花在file:1.94, scan:2.62, read.table:2.02。

5. 用profr可视化性能指标

安装profr


> install.packages("profr")
trying URL 'http://mirror.bjtu.edu.cn/cran/bin/windows/contrib/3.0/profr_0.2.zip'
Content type 'application/zip' length 25813 bytes (25 Kb)
opened URL
downloaded 25 Kb

package ‘profr’ successfully unpacked and MD5 sums checked

> library(profr)

数据可视化:第一个例子


> file<-"fun1_rprof.out"
> plot(parse_rprof(file))
> ggplot(parse_rprof(file))

plot-rplof

ggplot-rprof

数据可视化:第二个例子


> fileName <- "Rprof2.log"
> plot(parse_rprof(fileName))
> ggplot(parse_rprof(fileName))

plot-rprof2

ggplot-rprof2

6. Rprof的命令行使用

Rprof的命令行方法,用来方便的查看日志文件。

1). 查看Rprof命令行帮助


~ D:\workspace\R\preforemence\Rprof>R CMD Rprof --help
Usage: R CMD Rprof [options] [file]

Post-process profiling information in file generated by Rprof().

Options:
  -h, --help       print short help message and exit
  -v, --version    print version info and exit
  --lines          print line information
  --total          print only by total
  --self           print only by self
  --linesonly      print only by line (implies --lines)
  --min%total=     minimum % to print for 'by total'
  --min%self=      minimum % to print for 'by self'

If 'file' is omitted 'Rprof.out' is used

Report bugs at bugs.r-project.org .

命令行解释

  • -h, –help: 打印帮助信息
  • -v, –version: 打印版本信息
  • –lines: 打印显示多行
  • –total: 只显示总数
  • –self: 只显示自己
  • –linesonly: 只显示单行(配合–lines使用)
  • –min%total=: 显示total的不低于X的百分比
  • –min%self=: 显示self的不低于X的百分比

2). Rprof命令行使用

显示完整的报告


~ D:\workspace\R\preforemence\Rprof>R CMD Rprof fun1_rprof.out

Each sample represents 0.02 seconds.
Total run time: 0.14 seconds.

Total seconds: time spent in function and callees.
Self seconds: time spent in function alone.

   %       total       %        self
 total    seconds     self    seconds    name
 100.0      0.14       0.0      0.00     "fun1"
  71.4      0.10       0.0      0.00     "ddply"
  57.1      0.08       0.0      0.00     "ldply"
  42.9      0.06      42.9      0.06     ".fun"
  42.9      0.06       0.0      0.00     ".Call"
  42.9      0.06       0.0      0.00     ""
  42.9      0.06       0.0      0.00     "llply"
  42.9      0.06       0.0      0.00     "loop_apply"
  28.6      0.04      14.3      0.02     "paste"
  14.3      0.02      14.3      0.02     "[["
  14.3      0.02      14.3      0.02     "structure"
  14.3      0.02      14.3      0.02     "substr"
  14.3      0.02       0.0      0.00     "list_to_dataframe"
  14.3      0.02       0.0      0.00     "rbind.fill"
  14.3      0.02       0.0      0.00     "splitter_d"


   %        self       %      total
  self    seconds    total   seconds    name
  42.9      0.06      42.9      0.06     ".fun"
  14.3      0.02      28.6      0.04     "paste"
  14.3      0.02      14.3      0.02     "[["
  14.3      0.02      14.3      0.02     "structure"
  14.3      0.02      14.3      0.02     "substr"

只显示total指标,占用时间不低于50%的部分。


~ D:\workspace\R\preforemence\Rprof>R CMD Rprof --total --min%total=50 fun1_rprof.out

Each sample represents 0.02 seconds.
Total run time: 0.14 seconds.

Total seconds: time spent in function and callees.
Self seconds: time spent in function alone.

   %       total       %        self
 total    seconds     self    seconds    name
 100.0      0.14       0.0      0.00     "fun1"
  71.4      0.10       0.0      0.00     "ddply"
  57.1      0.08       0.0      0.00     "ldply"

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

打赏作者

R语言本地缓存memoise

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

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

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

关于作者:

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

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

memoise-r

前言

缓存技术在计算机系统中运用地非常广泛,特别是对于重复性计算,缓存能为我们节省大量的CPU时间,可能是99%。R语言以统计计算著名,但其中很多算法包都是在进行大量重复的计算。

优化正再进行,改变已经开始。以Hadley Wickham为代表的R语言领军人物,正在让R快起来!你感觉到了吗?!

目录

  1. memoise介绍
  2. memoise安装
  3. memoise的API介绍
  4. memoise使用
  5. memoise源代码分析

1. memoise介绍

memoise是一个简单的缓存包,主要用来减少重复计算,从而提升CPU性能。当你用相同的参数执行计算的时候,你会得到之前计算过的结果,而不是重算一遍。

缓存技术对于有并发访问的应用来说,是性价比最高的性能提升方案。

注:memoise包是“Hadley Wickham”大神的作品!

memoise的发布页:http://cran.r-project.org/web/packages/memoise/index.html

2. memoise安装

系统环境

  • Win7 64bit
  • R: 3.0.1 x86_64-w64-mingw32/x64 b4bit

memoise安装


~R

> install.packages("memoise")
trying URL 'http://mirror.bjtu.edu.cn/cran/bin/windows/contrib/3.0/memoise_0.1.zip'
Content type 'application/zip' length 10816 bytes (10 Kb)
opened URL
downloaded 10 Kb

package ‘memoise’ successfully unpacked and MD5 sums checked

memoise加载

> library(memoise)

3. memoise的API介绍

非常简单的API列表,只有2个函数。

  • forget: 重置缓存函数
  • memoize: 定义缓存函数

4. memoise使用

缓存测试


#定义缓存函数
> fun <- memoise(function(x) { Sys.sleep(1); runif(1) })

#第一次执行fun函数
> system.time(print(fun()))
[1] 0.05983416
用户 系统 流逝 
   0    0    1

#第二次执行fun函数 
> system.time(print(fun()))
[1] 0.05983416
用户 系统 流逝 
   0    0    0 

#重置缓存函数
> forget(fun)
[1] TRUE

#第三次执行fun函数 
> system.time(print(fun()))
[1] 0.6001663
用户 系统 流逝 
   0    0    1 
  • 1. 定义缓存函数memoise
  • 2. 第一次执行fun函数, 等待sleep(1)
  • 3. 第二次执行fun函数, 无等待,直接从缓存中返回结果
  • 4. 重置缓存函数forget
  • 5. 第三次执行fun函数, 由于fun被重置,返回2,等待sleep(1)

5. memoise源代码分析

1). memoise函数

  • 1. new_cache创建新的缓存空间,给f函数
  • 2. 生成f函数的hash值,作为key
  • 3. 返回缓存后的,f函数引入

memoise <- memoize <- function(f) {
  cache <- new_cache()
  
  memo_f <- function(...) {
    hash <- digest(list(...))
    
    if (cache$has_key(hash)) {
      cache$get(hash)
    } else {
      res <- f(...)
      cache$set(hash, res)
      res
    }
  }
  attr(memo_f, "memoised") <- TRUE
  return(memo_f)
}

2). forget函数

  • 1. 检查环境中,是否缓存了f函数
  • 2. 如果有f函数的缓存,则清空f函数的缓存值

forget <- function(f) {
  if (!is.function(f)) return(FALSE)
  
  env <- environment(f)
  if (!exists("cache", env, inherits = FALSE)) return(FALSE)
  
  cache <- get("cache", env)
  cache$reset()
  
  TRUE
}

3). 私有函数:new_cache函数

  • 1. 在new_cache函数里,定义cache对象,保存在env的环境中
  • 2. 通过new_cache函数,构造list类型对象,包括reset,set,get,has_key,keys方法
  • 3. 通过list对象,对cache对象进行访问操作

new_cache <- function() {
  
  cache <- NULL
  cache_reset <- function() {
    cache <<- new.env(TRUE, emptyenv())
  }
  
  cache_set <- function(key, value) {
    assign(key, value, env = cache)
  }
  
  cache_get <- function(key) {
    get(key, env = cache, inherits = FALSE)
  }
  
  cache_has_key <- function(key) {
    exists(key, env = cache, inherits = FALSE)
  }
  
  cache_reset()
  list(
    reset = cache_reset, 
    set = cache_set, 
    get = cache_get,
    has_key = cache_has_key,
    keys = function() ls(cache)
  )
}

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

打赏作者