有哪些很好玩而且很有用的 R 包？

12-29

技術渣一枚～但是覺得R包太太太強大～但目前只接觸了一些畫圖的，做統計檢驗的還有時間序列分析的這些很「正經」而且很主流（還都是老師告訴我們的……）的包…所以想請各路大神推薦R裡面很有意思而且很有用的包～比如rweibo之類的……非主流的那種～求推薦～

小眾的包我都不知道。。。只知道老掉牙的大眾的包。。。
既然說到了Rweibo，我當時做的project還用到了tm包，做文本挖掘的（現在有中文的tmcn包），還有Rwordseg包用來分詞。 wordcloud包用來分詞。

做相關矩陣的時候corrplot的圖形是一大神器

除了Rweibo包還有Rtwitter包，我記得好像google+也有對應的一個介麵包。否則就只用Rcurl RJson自己做爬蟲獲取數據。
可視化剛才有人提到了ggplot2，作者現在搞的ggvis我覺得也是很炫酷的，可以做互動式的圖了

shiny也很好玩。可以把你的R程序放在網上提供互動式界面給用戶使用。

如果你僅僅需要自己做一個地圖可視化的話，可以嘗試rMaps

如果你要做金融，quantmod包不可不嘗試，做出的圖很好看

果然是看臉的世界，好玩的包基本都是靠圖來吸引人。
其他靠譜實用包， Rcpp，用C++來加速，誰用誰知道。 Roxygen2，開發R包時寫文檔的利器。data.table，最近超級喜歡一個包，數據很快。e1071，我也不知道為什麼起名字這麼神秘，其實是R里做machine learning的屌包。ggplot2，就不用提了，作圖神器。我覺得有機會可以開發一個RSarah包，你覺得呢 @董可人

首先歡迎大家關注我的專欄：R語言與數據挖掘 - 知乎專欄

R的包真的有很多好玩的，比如fun、sudoku、wordcloud2、quantmod、jiebaR、Rweibo、Rtwitter、shiny等等，下面一一講解並附代碼：

1.fun包可以玩很多遊戲，比如說：
掃雷：

## install.packages("fun") library(fun) if (.Platform$OS.type == "windows") x11() else x11(type = "Xlib") mine_sweeper()

五子棋：

library(fun) gomoku()

2. 還有一個包叫做sudoku，可以設計數獨，解數獨

library(sudoku) playSudoku() #玩一個random的數獨遊戲

3. wordcloud2是一個完美的畫詞雲的軟體，不僅可以畫出炫目的詞云：

library(wordcloud2) wordcloud2(demoFreq, color = "random-light", backgroundColor = "grey")

還可以根據你給定的png畫出給定形狀的詞雲，比如說小鳥：

figPath = system.file("examples/t.png",package = "wordcloud2") wordcloud2(demoFreq, figPath = figPath, size = 1.5,color = "skyblue")

4.quantmod包是一個金融數據包，可以畫出k線圖

library(quantmod); getSymbols("GOOG",src="yahoo",from="2016-01-01", to="2016-05-30") chartSeries(GOOG,theme = "white",name="谷歌",up.col = "red",dn.col = "green")

library(quantmod) getSymbols("GOOG",src="yahoo",from="2016-01-01", to="2016-05-30") chartSeries(GOOG)

5.jiebaR的分詞

library(jiebaR) # 接受默認參數，建立分詞引擎 mixseg = worker() # 相當於： # worker( type = "mix", dict = "inst/dict/jieba.dict.utf8", # hmm = "inst/dict/hmm_model.utf8", # HMM模型數據 # user = "inst/dict/user.dict.utf8") # 用戶自定義詞庫 # Initialize jiebaR worker 初始化worker This function can initialize jiebaR workers. You can initialize different kinds of workers including mix, mp, hmm, query, tag, simhash, and keywords.

mixseg &<= "廣東省深圳市聯通" # &<= 分詞運算符 # 相當於segment函數，看起來還是用segment函數順眼一些 segment(code= "廣東省深圳市聯通" , jiebar = mixseg) # code A Chinese sentence or the path of a text file. # jiebar jiebaR Worker # 分詞結果 # [1] "廣東省" "深圳市" "聯通" mixseg &<= "你知道我不知道" # [1] "你" "知道" "我" "不" "知道" mixseg &<= "我昨天參加了同學婚禮" # [1] "我" "昨天" "參加" "了" "同學" "婚禮" 呵呵：分詞結果還算不錯

6.Rweibo與twitterR

Rweibo與twitterR分別是可以模擬登陸到weibo和twitter並抓取數據以進行畫圖文本分析的工具，比如下面這張圖是國外某人用twitterR發現某個賬戶的關注者的分布圖：

7.shiny

shiny是一個做web交互應用的包，比如可以做google charts

原網址例子在此：Shiny - Google Charts
更多例子：Shiny - Gallery記得點贊關注~

R語言中好玩的包首推謝大神的傑作——fun包。顧名思義，fun包集合了幾款遊戲以及有趣的demo，下面介紹幾個遊戲和有趣的功能：

掃雷——mine_sweeper()

掃雷，windows系統下的經典遊戲，fun包的mine_sweeper()可在R語言中玩掃雷遊戲，當第一次用R玩掃雷，著實被R驚艷了一把。

library(fun) if (.Platform$OS.type == "windows") x11() else x11(type = "Xlib") mine_sweeper()

五子棋——gomoku()

這個五子棋不是人機對戰，而是人人對戰，不會智能判斷判輸贏，用來下圍棋也是極好的。

if (.Platform$OS.type == "windows") x11() else x11(type = "Xlib") gomoku()

關燈遊戲——lights_out()

所謂關燈遊戲就是把所有的方片變成白色或者黑色。玩法很簡單：點一下其中一個方片，這個方片就會變成相反的顏色（黑變白或者白變黑），而與其緊鄰的四個方片也會變成相反的顏色。

if (.Platform$OS.type == "windows") x11() else x11(type = "Xlib") lights_out()

漢諾塔——tower_of_hanoi（）

漢諾塔是源於印度一個古老傳說的益智玩具：在世界中心貝拿勒斯的聖廟裡，一塊黃銅板上插著三根寶石針。印度教的主神梵天在創造世界的時候，在其中一根針上從下到上地穿好了由大到小的64片金片，這就是所謂的漢諾塔。不論白天黑夜，總有一個僧侶在按照下面的法則移動這些金片：一次只移動一片，不管在哪根針上，小片必須在大片上面。僧侶們預言，當所有的金片都從梵天穿好的那根針上移到另外一根針上時，世界就將在一聲霹靂中消滅，而梵塔、廟宇和眾生也都將同歸於盡。漢諾塔_百度百科

if (.Platform$OS.type == "windows") x11() else x11(type = "Xlib") tower_of_hanoi(7)

以下演示了七層的漢諾塔實現過程，只是顏色搭配真的很醜。

眾里尋他千百度——alzheimer_test()

這個遊戲與前一段風靡的「找熊貓」遊戲屬於一類遊戲，只不過是找的內容是是數字或字母，默認在9裡面找6，在O裡面找C，在M裡面找N等等，當然也可以自定義。輸入alzheimer_test()即可，然後按照提示輸入內容就可上手玩了，很簡單，不再上圖。

除了遊戲之外，fun包還有幾個有趣的功能，比如：

關閉電腦（windows系統）

shutdown(wait = 5)

5秒後，你的電腦就關機了（千萬不要手賤，數字可以自定義）。
這條命令實際上等於在cmd命令窗口中輸入「shutdown -s -t 5」，對於晚上睡前在被窩裡連WIFI玩手機的童鞋非常實用。

生成隨機密碼

有時候賬號要更換新密碼，想個新密碼想不出來怎麼辦？random_password()來幫忙！
random_password()默認生成長度為12， ASCII字元的密碼
當然，我們我們可以通過設置參數來生成指定長度的，由字母和數字組成的固定密碼。

set.seed(1949) random_password(length=6,replace=FALSE,extended=FALSE)

或省略參數名

set.seed(1949) random_password(6,F,F)

於是乎，我們就不用記住該死的密碼了，只需要記住種下的種子數即可。

此外，fun包還有一些有趣的demo，在此展示一個例子

生成心形國旗

demo("ChinaHeart2D")

最後，送給大家一個Surprise！
把上面代碼中的2改成3，然後執行，點擊Enter，即可看到！

一、雲詞圖包：

上次也有童鞋提及到wordcloud這個包，不過在今年6.1的時候，R有了新的雲詞包，wordcloud2，更能更加強大了，優勢特性包括：

（1）支持中英文

（2）支持文字形狀

（3）支持任意自定義形狀

先看效果，最後附教程，注意下面這些看上去這麼好玩的東西只需要兩行代碼，兩行代碼，兩行代碼！！！重要事情說三遍！

超級英雄系列：

蜘蛛俠

蝙蝠俠

情書系列

文字系列

教程：

1.自定義形狀圖片

首先先查看此次的自定義形狀，蝙蝠俠：

蝙蝠俠與蜘蛛俠圖片下載鏈接: http://pan.baidu.com/s/1pL5s87T 密碼: v652

2.環境準備

（1）

https://cran.r-project.org/上下載對應系統及版本的R軟體（版本要求至少3.1.0），環境為win64的R；

（2）

此次用到的包為「wordcloud2」，github上，因此我們需要先安裝「devtools」，再安裝「wordcloud2」，代碼如下：

install.packages("devtools")

devtools::install_github("lchiffon/wordcloud2")

3.最後實現

batman = system.file("examples/batman.png",package = "wordcloud2")

###讀取形狀圖片，注意圖片默認放在wordclou2的sample包中，浩彬老撕的路徑如下："d:/Program Files/R/R-3.3.0/library/wordcloud2/examples/batman.png"###

wordcloud2(demoFreq, figPath = batman, size = 1,color = "black")

###繪製雲此圖，其中demoFreg即為所用的數據，figPath = batman為所用圖片。注意demoFreg為wordcloud2自帶sample數據，此處可以改為自己所需要的任何數據

詳細教程可以參考：

R語言，一行代碼實現高大上的「高考文字雲」（附完整教程）

R語言，超級英雄雲詞圖，你們要的自定義形狀來了（附完整教程）

二、花式自動稱讚包

感謝最高贊的答案，所以才發現了這麼一個蛇精病的包，玩了一個小時，稍稍針對這個包再詳細介紹一下。

因為這個R包真的好有（she）腔（jing）調（bing）！

這個R包的名字叫做praise()，

它的功能就是贊你~贊你~贊你~

你問還有其他功能嗎？

難道還不夠嗎？！你想想，一個每次都能變著花樣稱讚你的R包難道還不夠嗎？！

簡直比男票女票還要稱職！

現在，每當浩彬老撕打開R的時候，界面是這樣的：

具體實現：

1.環境要求：

（1）The Comprehensive R Archive Network上下載對應系統及版本的R軟體；

（2）此次用到的包為「praise」，因為在github上，所以我們需要先安裝「devtools」，再安裝「praise」，代碼如下：

install.packages("devtools")

devtools::install_github("gaborcsardi/praise")

2.實現過程：

2.1 直接「贊」

library(praise) #載入praise

praise()#稱讚一下

2.2 自定義格式贊
praise不僅僅支持預設格式，還能根據需求自己設定內容：

praise("${EXCLAMATION}! You have done this ${adverb_manner}!")

其中 ${EXCLAMATION} 以及 ${adverb_manner 你可以理解為包中的詞庫，分別表示感嘆和情態，每個詞庫裡面都含有數量不等的用於稱讚你的詞語

具體詞庫見可通過names()查看：

names(praise_parts)

"adjective" "adverb" "adverb_manner" "created" "creating" "exclamation" "rpackage" "smiley"

2.3 設定為打開程序，花式自動贊

沒錯，就是文章開頭圖片所示，打開R，自動贊~

R語言當中，我們是可以自定義我們的啟動環境。

R在啟動時，會到R_Homeetc目錄下找Rprofile.site文件進行載入（其中R_Home指的是我們R的安裝路徑，例如浩彬老撕的目錄：D:Program FilesRR-3.3.1etc）。

在，這個文件里，設置的內容包括默認編輯器，CRAN鏡像選取，自動載入包等等，要實現我們的花式自動贊，只需要打開Rprofile.site文件，在最後加上如下代碼：

#啟動鼓勵2

.First &<- function(){

library(praise)

cat(praise("${EXCLAMATION}! ${EXCLAMATION}! Haobin,you have done this ${adverb_manner}!"),"
",praise(),"
",praise(),"
",date(),"
")

當然，這只是我個人的格式了，大家可以根據「被贊」的實際需要進行修改~

最後厚顏無恥地介紹我個人的公眾號，wetalkdata，定期更新數據分析，數據挖掘方法，以及「好物推薦」，而且還有送書活動！

http://weixin.qq.com/r/KEhPVwXE2VimrUE09x06 (二維碼自動識別)

寫一些最近常玩又沒有很多推廣的包, 大家有空可以去給這些包點個star什麼的..

xaringan
yihui/xaringan
益輝大大最近更新的一個做html5幻燈片的R包, 中文支持比傳統的slidify要好的多, 查克拉來自remark.js

ropencc
前段時間心心念一個將簡體中文轉繁體中文的包, 然後看到文峰大大(jiebaR作者)已經將opencc的庫搬到了r中, 一年前, 於是,就可以:
qinwf/ropencc

devtools::install_github("qinwf/ropencc") library(ropencc) converter(S2T)["開放中文轉換"] [1] "開放中文轉換"

windows要安裝啊兔子(Rtools)才能成功build

flexdashboard
rstudio/flexdashboard
如果你聽過shinydashboard,就知道這是一個用來做shiny的dashboard(我是不知道它怎麼用中文形容). 如果你想做靜態的dashboard, flexdashboard是不二之選, Rmd語法, 加上繪圖, 一個炫酷的靜態看板就出來了

recharts
R與Echarts3的介面, 主代碼手因為太忙所以該項目一直pending在github上, 16年9月更新到E3的依賴之後, 基本使用是沒問題了, 做個基本的條柱線還是很舒服的配上shiny或者dashboard系列毫無違和感.
taiyun/recharts

webshot
平時搞一些網頁報告想截圖放在幻燈片裡面, 但是每次截大小不一樣, 於是挖出來webshot這個包, 可以用來做網頁截圖, 當然, 是在Ｒ裡面．
wch/webshotREmap
基於Echarts2做的地圖介面, 可以做svg或者是基於百度地圖的繪製,生成一個html的地圖
Lchiffon/REmap

library(devtools) install_github("lchiffon/REmap") remap(demoC)

wordcloud2
基於wordcloud2.js的詞雲可視化, 之前有人提過, 可以做詞雲, 做形狀, 做字元~
Lchiffon/wordcloud2

install.packages("wordcloud2") library(wordcloud2) wordcloud2(demoFreqC, size = 2, fontFamily = "微軟雅黑", color = "random-light", backgroundColor = "grey")

leafletCN
在leaflet基礎上製作的基於中國地圖的繪製, 可以把區劃信息繪製在openStreetMap或者是高德上
比如用十行代碼看到AQI
Lchiffon/leafletCN

install.packages("leafletCN")

應該沒啥必要更新吧...

explainr. 是我目前見過最好玩兒又很有用的包
簡直是太好玩兒了，而且還方便科普統計知識。
這是Etsy Senior data scientist 做的一個包，針對reproducible analysis report的。
衍生品有：
catsplainr，可以解釋結果之後畫個貓。
complainr，以抱怨的語氣解釋結果。
mansplainr, 大男子主義的語氣。

你還可以自己做一些口氣來玩兒，也可以很認真的拿來做template。
詳見：hilaryparker/explainr · GitHub

opencpu不錯，可以把R包發布成一個API，別人可以通過網路調用你的計算函數。

data analysis for dota2

強推jiebaR
樓上提到的Rwordseg、Rweibo停更很久了，jiebaR應該是目前最好用的R上的中文分詞包了，分詞結果很好而且速度很快，是用Rcpp和CppJieba開發的，據說比原來python上的還快5-10倍。
附上github地址：GitHub - qinwf/jiebaR: Chinese text segmentation with R. R語言中文分詞，而且作者人很nice，回的超快。
作者還有一個介紹各種好用R包的repo!:
GitHub - qinwf/awesome-R: A curated list of awesome R packages, frameworks and software.

歡迎大家關注R語言官方專欄：R語言中文社區 - 知乎專欄

R包可以做一些遊戲，比如貪食蛇、天氣預報、2048、創作古詩、穩定婚姻問題等等。
下面的代碼供參考。

1、貪食蛇 R語言遊戲之旅貪食蛇入門（附代碼） - 知乎專欄

【部分代碼案例】

用R語言寫代碼，其實沒有幾行就可以搞定，按照上面的函數定義，我們把代碼像填空一樣地寫進去就行了。當然，在寫代碼的過程中，我們需要掌握一些R語言特性，讓代碼更健壯。

run()函數，啟動程序。

run&<-function(){ # 設置全局畫布無邊 par(mai=rep(0,4),oma=rep(0,4)) # 定義全局環境空間，用於封裝變數 e&<&<-new.env() # 啟動開機場景 stage0() # 註冊鍵盤事件 getGraphicsEvent(prompt="Snake Game",onKeybd=keydown) }

上面代碼中，通過定義環境空間e來存儲變數，可以有效的解決變數名衝突，和變數污染的問題，關於環境空間的介紹，請參考文章：揭開R語言中環境空間的神秘面紗，解密R語言函數的環境空間。

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") { 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_furit&<-2 #水果顏色 e$col_head&<-4 #蛇頭顏色 e$col_tail&<-8 #蛇尾顏色 e$col_path&<-0 #路顏色 }

代碼中，初始化全局的環境空間e，然後將所有需要的變數，定義在e中。

furit():判斷並生成水果坐標。

# 隨機的水果點 furit&<-function(){ if(length(index(e$col_furit))&<=0){ #不存在水果 idx&<-sample(index(e$col_path),1) fx&<-ifelse(idx%%e$w==0,10,idx%%e$width) fy&<-ceiling(idx/e$height) e$m[fx,fy]&<-e$col_furit print(paste("furit idx",idx)) print(paste("furit axis:",fx,fy)) } }

fail():失敗查詢，判斷蛇頭是否撞牆或蛇尾，如果失敗則跳過畫圖，進入結束場景。

# 檢查失敗 fail&<-function(){ # head出邊界 if(length(which(e$head&<1))&>0 | length(which(e$head&>e$width))&>0){ print("game over: Out of ledge.") keydown("q") return(TRUE) }


    # head碰到tail

    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():生成蛇頭移動坐標。

# 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 }

body():生成蛇尾移動坐標。

# snake 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_furit))&<=0){ #不存在水果 e$tail&<-rbind(e$tail,data.frame(x=e$lastx,y=e$lasty)) } if(nrow(e$tail)&>0) { #如果有尾巴 e$tail&<-rbind(e$tail,data.frame(x=e$lastx,y=e$lasty)) 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$w==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 furit&<-function(){...} //見furit fail&<-function(){...} //見fail head&<-function(){...} //見head body&<-function(){...}//見body drawTable&<-function(){...} //見drawTable drawMatrix&<-function(){...} //見drawMatrix # 運行函數 furit() head() if(!fail()){ #失敗檢查 body() drawTable() drawMatrix() } }

註：此處代碼為偽代碼。

最後，是完整的程序代碼。

# 初始化環境變數 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_furit&<-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 # 隨機的水果點 furit&<-function(){ if(length(index(e$col_furit))&<=0){ #不存在水果 idx&<-sample(index(e$col_path),1) fx&<-ifelse(idx%%e$w==0,10,idx%%e$width) fy&<-ceiling(idx/e$height) e$m[fx,fy]&<-e$col_furit print(paste("furit idx",idx)) print(paste("furit axis:",fx,fy)) } } # 檢查失敗 fail&<-function(){ # head出邊界 if(length(which(e$head&<1))&>0 | length(which(e$head&>e$width))&>0){ print("game over: Out of ledge.") keydown("q") return(TRUE) }


    # head碰到tail

    if(e$m[e$head[1],e$head[2]]==e$col_tail){

      print("game over: head hit tail")

      keydown("q")

      return(TRUE)

    }
    return(FALSE)

  }

# 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(){ e$m[e$lastx,e$lasty]&<-0 e$m[e$head[1],e$head[2]]&<-e$col_head #snake if(length(index(e$col_furit))&<=0){ #不存在水果 e$tail&<-rbind(e$tail,data.frame(x=e$lastx,y=e$lasty)) } if(nrow(e$tail)&>0) { #如果有尾巴 e$tail&<-rbind(e$tail,data.frame(x=e$lastx,y=e$lasty)) 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$w==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) } furit() 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()

遊戲截圖：

2、每日中國天氣 R包開發每日中國天氣 - 知乎專欄

編寫功能代碼

按照函數功能的不同，我們定義4個文件來描述這些函數。

getData.R，用於定義爬去數據的函數。
render.R，用於靜態圖片可視化渲染的函數。
chinaWeather.R，用於定義各種工具函數。
chinaWeather-packages.R，用於定義R包內的數據集。

3.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/forecastrss?w=",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)) }

3.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=""),w=600,h=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.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)]) }

3.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/forecastrss?w=2151330} "weather20141001"

3、2048遊戲 R語言遊戲之旅遊戲2048 - 知乎專欄

4.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包的介紹，請參考文章在巨人的肩膀前行催化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)))

當然，我們還可以寫更多的測試用例，來檢驗函數的正確性。這樣就實現了，數字移動的核心演算法了。

4.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() }

完整的程序代碼

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()

4、創作古詩如何用 R 創作古詩 - 知乎專欄

詩詞創作

準備

創作宋詞，先要明確一個詞牌名。我選擇了李白的《清平樂·畫堂晨起》作為範例。

畫堂晨起，來報雪花墜。高捲簾櫳看佳瑞，皓色遠迷庭砌。盛氣光引爐煙，素草寒生玉佩。應是天仙狂醉，亂把白雲揉碎。

R 的中文分詞包『結巴R』的功能中，有一項可以用來分辨詞語的詞性。我將範例進行分詞後，再用這項功能分析一下各部分的詞性。

&> cipai &<- "畫堂晨起，來報雪花墜。高捲簾櫳看佳瑞，皓色遠迷庭砌。盛氣光引爐煙，素草寒生玉佩。應是天仙狂醉，亂把白雲揉碎。" &> tagger &<- worker("tag") &> cipai_2 &<- tagger &<= cipai &> cipai_2 n x x n v a n g v "畫堂" "晨起" "來報" "雪花" "墜" "高" "捲簾" "櫳" "看" x x a v x n x x x "佳瑞" "皓色" "遠" "迷" "庭砌" "盛氣" "光引" "爐煙" "素草" x nr x n x d p nr v "寒生" "玉佩" "應是" "天仙" "狂醉" "亂" "把" "白雲" "揉碎"

其中每個字母代表什麼詞性，我也沒有很理解。據我的猜測，n 應該是名詞，x是沒有分辨出來的詞性，v是動詞， a是形容詞，至於『nr』, 『p』, 『d』是什麼，實在是猜不出來，在幫助文檔中也沒有找到。如果有朋友知道的話，希望能不吝賜教。

最後，我從之前提煉的宋詞詞頻庫中，選取了至少出現過兩次的一字或兩字詞語，作為詩詞創作的素材庫：

&> example &<- subset(analysis, freq &>1 nchar(word) &<3 freq &< 300) # 提取詞性文件 &> cixing &<- attributes(cipai_2)$names # 將素材庫進行詞性分類 &> example_2 &<- tagger &<= example$word

創作

下面，我們終於要開始用 R 創作詩歌了！我自己想了一個創作的演算法，可以說很簡單，甚至說有點可笑。

步驟是這樣的：我從範本詞牌的第一個詞開始，隨機在素材庫中選取詞性相同，字數相等的單詞，填入提前設置好的空白字元串中。

舉個例子，原詩的第一個詞是『畫堂』，是個二字的名詞。那麼，我就在素材庫中隨機選擇一個二字的名詞，填入這個空間中。然後，繼續分析下一個詞。

具體方程的代碼如下：

&> write_songci &<- function(m){ set.seed(m) empty &<- "" for (i in 1:length(cipai_2)){ temp_file &<- example_2[attributes(example_2)$name == cixing[i]] temp_file &<- temp_file[nchar(temp_file) == nchar(cipai_2[i])] empty &<- paste0(empty, sample(temp_file,1)) } result &<- paste0(substr(empty, 1,4), ",", substr(empty,5,9),"。", substr(empty, 10,16), ",", substr(empty, 17,22),"。", substr(empty, 23,28), ",", substr(empty, 29,34),"。", substr(empty, 35,40), ",", substr(empty, 41,46),"。") }

歡迎大家關注R語言官方專欄：R語言中文社區 - 知乎專欄，每日都有連載更新，謝謝。

講一個昨天發現的ggplot2插件，ggsignif：

這個包只給ggplot2增加了一個功能：給圖標註顯著性的連線、星號或p值，可以手工指定具體符號也可以通過計算得出。。對科研人員來說簡直太有用了，尼瑪這個是畫圖痛點啊。。

具體用法見軟體PDF文檔及Github鏈接：const-ae/ggsignif

說一個我之前用過，非常實用的R包：mailR

主要的功能就是用來發郵件，支持群發支持附件。

由於工作原因需要每天生成數據分析報告。在重複工作多次之後終於忍不了了，於是乎利用yihui大大的Rmarkdown自動生成了PDF/HTML版本的分析結果報告，然後直接利用mailR發送給相關人員，順便抄送自己一份。

後來部署在遠程伺服器，設定了計劃任務，從此以後上班第一件事兒就從點擊數次outlook，變為了打開郵件花幾分鐘看一下數據有沒有出現大的偏差，沒有的話就可以直接去做別的事情了。

人類的工作應該是利用機器，而不是像機器一樣做重複的工作。

最後放一個收藏的博客地址，裡面還是有不錯的幾個包的推薦的：R語言實用小技巧

啊，打字好累啊！

fun animation 遊戲和圖
ggplot2族畫圖
Rcurl rjson 等網路接入
rstudio貢獻的幾個包都可以看看，包括網路接入api等
knitr 文學化編程
做performance profile的幾個包
bioconductor還有亂七八糟畫圖的

前面有人介紹了ggsignif用來計算以及標註顯著性。

也有一款更為方便的基於ggplot2的包，ggpubr . 它可以直接幫你畫出箱線圖、密度分布圖、直方圖、點圖、偏差圖的同時標上significance levels，主要是使用起來也十分簡單。

見下圖：

# Add p-values comparing groups # Specify the comparisons you want my_comparisons &<- list( c("0.5", "1"), c("1", "2"), c("0.5", "2") ) p + stat_compare_means(comparisons = my_comparisons)+ # Add pairwise comparisons p-value stat_compare_means(label.y = 50) # Add global p-value

# Violin plots with box plots inside # ::::::::::::::::::::::::::::::::::::::::::::::::::: # Change fill color by groups: dose # add boxplot with white fill color ggviolin(df, x = "dose", y = "len", fill = "dose", palette = c("#00AFBB", "#E7B800", "#FC4E07"), add = "boxplot", add.params = list(fill = "white"))+ stat_compare_means(comparisons = my_comparisons, label = "p.signif")+ # Add significance levels stat_compare_means(label.y = 50)

ggdotchart(dfm, x = "name", y = "mpg_z", color = "cyl", # Color by groups palette = c("#00AFBB", "#E7B800", "#FC4E07"), # Custom color palette sorting = "descending", # Sort value in descending order add = "segments", # Add segments from y = 0 to dots add.params = list(color = "lightgray", size = 2), # Change segment color and size group = "cyl", # Order by groups dot.size = 6, # Large dot size label = round(dfm$mpg_z,1), # Add mpg values as dot labels font.label = list(color = "white", size = 9, vjust = 0.5), # Adjust label parameters ggtheme = theme_pubr() # ggplot2 theme )+ geom_hline(yintercept = 0, linetype = 2, color = "lightgray")

# Histogram plot with mean lines and marginal rug # ::::::::::::::::::::::::::::::::::::::::::::::::::: # Change outline and fill colors by groups ("sex") # Use custom color palette gghistogram(wdata, x = "weight", add = "mean", rug = TRUE, color = "sex", fill = "sex", palette = c("#00AFBB", "#E7B800"))

Ref: "ggplot2" Based Publication Ready Plots ? ggpubr

還有一個可以批量相關性分析並畫圖的包叫GGally, 它最初的功能是用來快速的畫出置信區間，但是我更喜歡它的ggpairs函數，用來快速進行相關性分析。

見下圖。

置信區間：

d &<- as.data.frame(Titanic) log.reg &<- glm(Survived ~ Sex + Age + Class, family = binomial, data = d, weights = d$Freq) ggcoef(log.reg, exponentiate = TRUE)