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

thuquant 网友的相关建议:

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

记得点赞关注~

liangyong1107 网友的相关建议:

欢迎大家关注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$width==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$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   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$width==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$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)   }      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=''),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.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语言中文社区 - 知乎专栏，每日都有连载更新，谢谢。

有哪些很好玩而且很有用的 R 包？的其他答案点击这里

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

编写功能代码

相关话题

前一个讨论

下一个讨论

相关的话题

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

编写功能代码

相关话题

前一个讨论

下一个讨论

相关的话题

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