技巧篇：常用的R代码汇总
模块1：Xpath的一些练习
#install.packages("rvest")
#install.packages("xlsx")
#install.packages("base")
library(base)
library(xlsx)
library(rvest) #爬虫
library(XML)
library(RCurl)
library(rjson)
library(rJava)
# install.packages("RJSONIO")
# install.packages("jsonlite")
??rvest
txt="abcd123456"
sub(pattern = ".*(\\d.+?)",replacement = "\\1",txt)
txt<-"dataurl: \"http://datainterface.eastmoney.com/EM_DataCenter/JS.aspx?type=SR&sty=YJBB&code=000001&st={sortType}&sr={sortRule}&p={page}&ps={pageSize}&js=var {jsname}={pages:(pc),data:[(x)]}{param}\","
RCurl="http://data.eastmoney.com/bbsj/stock000001/yjbb.html"
#response<-getURL(RCurl) # 直接抓源代码
#response<-getURL(RCurl,encoding ="utf-8") # 怎么转码？
txt<-readLines(RCurl)#读行
html<-txt[grep(pattern = "dataurl",txt)]#解析源代码，正则找行代码中含有dataurl的行
html<-sub(pattern = "\\{.+\\}.+",replacement = "",html)
NewUrl<-sub(pattern = "\\s.+dataurl:.*?(http:.+)&st=",replacement = "\\1",html)
NewUrl
write.table(response,"~/re.txt",row.names=F,quote=FALSE,fileEncoding = "UTF-8")
#============Model_One=================
url<-"http://www.scsf.gov.cn/website/second_orgInfo?aab001=510100030301070000&aab019="
temp<-getURL(url)
readHTMLTable(temp)
#============案例1：取如家地址及分布================
# install.packages("RCurl")
# install.packages("XML")
library(bitops)
library(RCurl)
library(XML)
url_initial <- "http://www.homeinns.com/homeinn-hotel"
txt_initial <- getURL(url_initial, .encoding="utf-8")
txt_initial <- htmlParse(txt_initial, asText=TRUE, encoding="utf-8")
txt_pinyin <- unlist(getNodeSet(doc=txt_initial, path="//ul[@class='ml_order_link']/li/a/@href"), use.names=FALSE)
# 参考：http://www.52ij.com/jishu/XML/12424.html
# 参考：http://www.w3school.com.cn/xpath/xpath_syntax.asp
# 获取所有城市的拼音代码
getNodeSet(doc=txt_initial, path="//ul[@class='ml_order_link']/li/a/@href")
url_head <- "http://www.homeinns.com/jieyang/homeinn"
txt_head <- getURL(url_head, .encoding="utf-8")
txt_head <- htmlParse(txt_head, asText=TRUE, encoding="utf-8")
maxpage <- as.numeric(unlist(getNodeSet(doc=txt_head, path="//input[@id='maxPage']/@value"), use.names=FALSE))
# 获取每个城市如家酒店的最大页码
url_hotellist <- "http://www.homeinns.com/beijing/homeinn"
txt_hotellist <- getURL(url_hotellist, .encoding="utf-8")
txt_hotellist <- htmlParse(txt_hotellist, asText=TRUE, encoding="utf-8")
iconv(unlist(getNodeSet(doc=txt_hotellist, path="//a/@hotelname"), use.names=FALSE),"utf-8","gbk")
# 获取某个城市首页所有酒店名称
# 通过hotelname属性直接定位酒店名称
# 获取的酒店名称全是乱码
# 乱码解决参考资料：http://bbs.pinggu.org/thread-3335814-1-1.html
t<-iconv(unlist(getNodeSet(doc=txt_hotellist, path="//ul[@class='list_intro_address_tj']/@title"), use.names=FALSE), "utf-8", "gbk")
mode(t)
t
x <- getNodeSet(doc=txt_hotellist, path="//ul[@class='list_intro_address_tj']/text()")
x
x<-xmlNode(doc=txt_hotellist, path="//ul[@class='list_intro_address_tj']/text()")
xmlValue(x)
mode(xx)
# unlist后仍然是list？奇怪!
#===========案例2：华丽的分割线==========
library(XML)
library(RCurl)
url <- 'http://www.pbc.gov.cn/diaochatongjisi/116219/116229/11877/index1.html'
html <- htmlParse(url,encoding="UTF-8")
hlist<-unlist(getNodeSet(html,path="//font[@class='newslist_style']/a/@href"),use.names = F)
hlist
tlist<-unlist(getNodeSet(html,path="//font[@class='newslist_style']/a/@title"),use.names = F)
tlist<-iconv(tlist,"utf-8","gbk")
tlist
rlist<-data.frame("herf"=hlist,"title"=tlist)
rlist
#下面是提取整个字节
raw <- iconv(xpathSApply(html,"//font[@class='newslist_style']/a[@href]",xmlAttrs),"UTF-8","GBK")
unlist(raw)
head(raw)
#==========案例3：Xpath练习=============
library(XML)
library(RCurl)
url<-"http://sj.qq.com/myapp/"
html<-htmlParse(url,encoding = "UTF-8")
url <- 'http://www.pbc.gov.cn/diaochatongjisi/116219/116229/11877/index1.html'
html<-htmlParse(url,encoding = "UTF-8")
xmlTreeParse(url,useInternal=TRUE,encoding="UTF-8")
html
xpathSApply(html,"//tr[@class='info']",use.names=F)
url<-"http://aso100.com/index.php/trend/hotSearch"
html<-htmlParse(url,encoding = "UTF-8")
html
lit<-xpathSApply(html,"//div [@class='container']/div//li/a/text()",xmlValue)
unlist(lit,use.names = F)
gett<-function(url){
html<-htmlParse(url,encoding = "UTF-8")
xpathSApply(html,"//*/[@class='info']",use.names=F)
}
gett(url)
#===========案例4：读取祖父节点并分层==============
rm(list=ls())
library(XML)
library(RCurl)
library(tidyr)
library(dplyr)
url_initial <- "http://www.homeinns.com/homeinn-hotel"
txt_initial <- getURL(url_initial, .encoding="utf-8")
txt_initial <- htmlParse(txt_initial, asText=TRUE, encoding="utf-8")
getNodeSet(doc=txt_initial, path="//div [@class='ml_order_row']/ul/..")
txt_tt<-unlist(xpathSApply(txt_initial,path="//div [@class='ml_order_row']/ul",xmlValue),use.names = F)
tt<-matrix(txt_tt,ncol = 2,byrow =T)
td<-as.data.frame(tt)
colnames(td)<-c("a","b")
#将b列从因子转化成为字符，factor→character
td$b<-as.character(td$b)
t1=transform(td,b=strsplit(td$b,"\\s"))
t1=unnest(t1,col = b)
te<-td%>%
transform(b= strsplit(b,"\\s"))%>%
unnest(b)
tf<-te[which(te$b!=""),]
write.csv(tf,"tf.csv")
#=========案例5：=======================
for (i in 2:3) {
url <- paste('http://www.cbrc.gov.cn/chinese/indexhome/04¤t=',i,sep='')
html <- htmlParse(url,encoding="UTF-8")
htemp <- xpathSApply(html,"//td[@class='cc' and @height ='32']/a[@title]",xmlGetAttr,'href')
h<- paste('http://www.cbrc.gov.cn',htemp,sep='')
href <- unlist(h)
ttemp <- xpathSApply(html,"//td[@class='cc' and @height ='32']/a[@title]",xmlGetAttr,'title')
t <- iconv(ttemp,"utf-8","gbk")
title <- unlist(t)
}
rlist<-data.frame("herf"=href,"title"=title)
write.csv(rlist,"rlist.csv")
#=========案例6:获取飞行距离===============
library(RCurl)
#加载RCurl包
getKm<-function(x){
d=debugGatherer()
#设置debugGatherer，响应response
myHttpheader<-c("User-Agent"="Mozilla/5.0 (Windows NT 6.1; rv:41.0) Gecko/20100101 Firefox/41.0",
"Accept"="text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8")
#设置headers格式
temp<-getURL(paste("http://zh.flightaware.com/live/flight/",x,sep=""),httpheader=myHttpheader,
debugfunction=d$update,verbose=T,followlocation=T)
#获取网页信息
temp1<-d$value()[["headerIn"]]
url1<-regmatches(temp1,regexpr(pattern = "http:.+Vary",temp1))
url2<-unlist(strsplit(url1,"\r"))[1]
t=regmatches(url2,regexpr("\\d+{1,}$",url2))
t1=as.numeric(t)*1
url=paste(unlist(strsplit(url2,t)),t1,sep="")
#处理网页得到url地址
temp2<-getURL(url)
write(temp2,"~/tt.txt")
k=regexpr(pattern = "计划飞行距离.+km( |</td>)",temp2)
dat=regmatches(temp2,k)
#dat=regmatches(dat,regexpr("\\d.+\\d",dat))
dat
}
getKm("EY311")
getKm("EY191")
getKm("KL1763")
getKm("KL1139")
#=======案例7===================？charset:gb2132有问题
library(RCurl)
library(XML)
url="http://binjianghuayuansm.fang.com/xiangqing"
myheader<-c(
"User-Agent"="Mozilla/5.0 (Windows; U; Windows NT 5.1; zh-CN; rv:1.9.1.6) ",
"Accept"="text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8",
"Accept-Language"="en-us",
"Connection"="keep-alive",
"Accept-Charset"="GB2312,utf-8;q=0.7,*;q=0.7"
)
i_url.html<-htmlParse(url,encoding = 'gbk')
i_url.html
id.vector<-xpathSApply(i_url.html,"//*[@class='lbox']",xmlValue)
id.vector
iconv(id.vector,"gbk","")
getURL(url)
#======案例8================
library(RCurl)
library(XML)
library(stringr)
library(dplyr)
library(tidyr)
url<-c("http://www.jiwu.com/zhuanti/")
i_url.html<-htmlParse(url,encoding="UTF-8")
#读取链接
# xpath<-getNodeSet(i_url.html,"//div[@class='tabcon']")
# dat<-xpathSApply(i_url.html,"//div[@class='tabcon']",xmlValue)
One<-xpathSApply(i_url.html,"//div[@class='tabcon']/p",xmlValue)
Two<-unlist(xpathSApply(i_url.html,"//div[@class='tabcon']//ul",xmlValue),use.names = F)
Two=unlist(str_replace_all(Two,"\\s+"," "))
tt<-data.frame(a=One,b=Two)
tt$b=as.character(tt$b)
te<-tt%>%
transform(b= strsplit(b, " "))%>%
unnest(b)
模块2：绘制物流路线地图
#_author:夏天
#_modify:xisuo
#_version:v1.1
# ===========载入包===========
library(maps)
library(ggplot2)
library(sp)
library(lattice)
library(foreign)
library(maptools)
# library(directlabels) ##不支持##
library(mapproj)
library(plyr)
library(dplyr)
library(reshape2)
library(ggsubplot)
library(RODBC)
library(grid)
##导入订单路线数据##
setwd("C:\\Users\\users\\Documents\\R\\物流路线分析")
data=read.table(file="订单路线1.txt",header=T,sep=',')
data1=as.matrix(data)
head(data1)
##除去同城物流路线（起始地等于目的地）##
a=c()
q=1
for (i in 1:1503)
{
if (data1[i,1]==data1[i,2])
{
a[q]=i
q=q+1
}
}
a ##储存同城物流路线的编号##
data2=data1[-a,]
##储存包含一个中转地的路线到矩阵b##
b=matrix(0,nrow = 22796,ncol = 3)
s=1
for(i in 1:1461)
{
p=data2[i,2]
for(j in 1:1461)
{
if (data2[j,1]==p)
{
b[s,1]=data2[i,1]
b[s,2]=data2[i,2]
b[s,3]=data2[j,2]
s=s+1
}
}
}
s ##s为路线总数##
##根据起始地和目的地查询路线##
m="广州市"
n="北京市"
##提取起始地和目的地的经纬度数据##
citydata=read.table(file="城市经纬度数据1.txt",header=T,sep=',')
routenumber=read.table(file="订单路线次数1.txt",header=T,sep=',')
for(i in 1:dim(citydata)[1])
{
if(citydata[i,1]==m)
{
long1=citydata[i,2]
lat1=citydata[i,3]
}
if(citydata[i,1]==n)
{
long2=citydata[i,2]
lat2=citydata[i,3]
}
}
##起始地与目的地之间的距离##
distance1=sqrt((long1-long2)^2+(lat1-lat2)^2)
##直达路线##
route=matrix(nrow=1,ncol=4) ##储存直达路线和中转路线##
citysite=matrix(nrow=1,ncol=3) ##储存城市经纬度##
d=dim(data2)
g=1 ##group数据##
for(i in 1:d[1])
{
if(data2[i,1]==m & data2[i,2]==n)
{
for (j in 1:dim(routenumber)[1])
{
if (routenumber[j,1]==m & routenumber[j,2]==n)
{
number1=routenumber[j,3] ##订单次数数据##
}
}
route=rbind(route,matrix(c(g,long1,lat1,number1,g,long2,lat2,number1),nrow=2,ncol=4,byrow=T))
citysite=rbind(citysite,matrix(c(m,long1,lat1,n,long2,lat2),nrow=2,ncol=3,byrow=T))
g=g+1
}
}
##中转一次路线##
for(i in 1:s)
{
if(b[i,1]==m & b[i,3]==n)
{
for (j in 1:dim(citydata)[1])
{
if (citydata[j,1]==b[i,2])
{
long3=citydata[j,2]
lat3=citydata[j,3]
distance2=sqrt((long3-long1)^2+(lat3-lat1)^2)+sqrt((long3-long2)^2+(lat3-lat2)^2)
}
}
if (distance2<(distance1*1.3))
{
for (j in 1:dim(routenumber)[1])
{
if (routenumber[j,1]==m & routenumber[j,2]==b[i,2])
{
number1=routenumber[j,3]
}
if (routenumber[j,1]==b[i,2] & routenumber[j,2]==n)
{
number2=routenumber[j,3]
}
}
citysite=rbind(citysite,matrix(c(b[i,2],long3,lat3),nrow=1,ncol=3,byrow=T))
route=rbind(route,matrix(c(g,long1,lat1,number1,g,long3,lat3,number1,g+1,long3,lat3,number2,g+1,long2,lat2,number2),nrow=4,ncol=4,byrow=T))
g=g+2
}
}
}
route=data.frame(route[-1,])
citysite=data.frame(citysite[-1,])
names(route)=c("group","long","lat","number")
names(citysite)=c("city","long","lat")
citysite_copy=citysite
citysite_copy[,2]=as.double(sapply(citysite['long'],as.character))
citysite_copy[,3]=as.double(sapply(citysite['lat'],as.character))
citysite_copy
##导入地图和数据##
mymap = readShapePoly(system.file("shapes/bou2_4p.shp",package = 'maptools')) # 读取地图空间数据
mymapd <- fortify(mymap) #转化为数据框
citydata1=read.table(file="订单路线覆盖城市1.txt",header=T,sep=',')
citydata1=citydata[,-4]
t1=ggplot()+
geom_polygon(data=mymapd,aes(x=long,y=lat,group=group),color="grey60",fill="white")+
geom_line(data=route,aes(x=long,y=lat,group=group,color=number),arrow=arrow(angle=10,length=unit(0.2,"inches"),ends='last',type = 'closed'))+
scale_color_continuous(name='number',breaks=c(0,20,80,160),low = 'blue', high = 'red',guide='colourbar')+
geom_point(data=citysite_copy,aes(x=long,y=lat))+
geom_text(aes(x=long,y=lat,label=city),data=citysite_copy,color="gray0",size=5)+
ylim(15,55)+
expand_limits()+
theme(
panel.grid = element_blank(),
panel.background = element_blank(),
axis.text = element_blank(),
axis.ticks = element_blank(),
axis.title = element_blank(),
legend.background = element_blank(),
legend.position='right',
legend.title = element_text(colour='grey30',size=16),
legend.text = element_text(colour="black", face = "bold",size=16),
# legend.justification=c(0,0), # 这个参数设置很关键
# legend.position=c(0.05,0.1),
plot.margin = unit(c(0,0,0,0),"cm"),
legend.key.size=unit(1.5,'cm')
)
t1
##所有订单路线图##
route1=matrix(nrow=1,ncol=5)
g1=1
for(i in 1:dim(data2)[1])
{
for (j in 1:dim(citydata)[1])
{
if (citydata[j,1]==data2[i,1])
{
long1=citydata[j,2]
lat1=citydata[j,3]
}
if (citydata[j,1]==data2[i,2])
{
long2=citydata[j,2]
lat2=citydata[j,3]
}
}
for(h in 1:dim(routenumber)[1])
{
if (routenumber[h,1]==data2[i,1] & routenumber[h,2]==data2[i,2])
{
number1=routenumber[h,3]
}
}
route1=rbind(route1,matrix(c(g1,long1,lat1,number1,data2[i,1],g1,long2,lat2,number1,data2[i,2]),nrow=2,ncol=5,byrow=T))
g1=g1+1
}
route1=data.frame(route1[-1,])
names(route1)=c("group","long","lat","number","city")
t2=ggplot()+
geom_polygon(data=mymapd,aes(x=long,y=lat,group=group),color="grey60",fill="white")+
geom_line(data=route1,aes(x=long,y=lat,group=group,color=number),arrow=arrow(angle=10,length=unit(0.2,"inches"),ends='last',type = 'closed'))+
scale_color_continuous(name='number',breaks=c(0,20,80,160),low = 'blue', high = 'red',guide='colourbar')+
geom_point(data=route1,aes(x=long,y=lat))+
geom_text(aes(x=long,y=lat,label=city),data=route1,color="gray0",size=5)+
ylim(15,55)+
expand_limits()+
theme(
panel.grid = element_blank(),
panel.background = element_blank(),
axis.text = element_blank(),
axis.ticks = element_blank(),
axis.title = element_blank(),
legend.background = element_blank(),
legend.position='right',
legend.title = element_text(colour='grey30',size=16),
legend.text = element_text(colour="black", face = "bold",size=16),
# legend.justification=c(0,0), # 这个参数设置很关键
# legend.position=c(0.05,0.1),
plot.margin = unit(c(0,0,0,0),"cm"),
legend.key.size=unit(1.5,'cm')
)
t2
##次数5次以上的订单路线图##
data3=read.table(file="5次以上订单路线1.txt",header=T,sep=',')
data3=as.matrix(data3)
route2=matrix(nrow=1,ncol=5)
g2=1
for(i in 1:dim(data3)[1])
{
for (j in 1:dim(citydata)[1])
{
if (citydata[j,1]==data3[i,1])
{
long1=citydata[j,2]
lat1=citydata[j,3]
}
if (citydata[j,1]==data3[i,2])
{
long2=citydata[j,2]
lat2=citydata[j,3]
}
}
for(h in 1:dim(routenumber)[1])
{
if (routenumber[h,1]==data3[i,1] & routenumber[h,2]==data3[i,2])
{
number1=routenumber[h,3]
}
}
route2=rbind(route2,matrix(c(g2,long1,lat1,number1,data3[i,1],g2,long2,lat2,number1,data3[i,2]),nrow=2,ncol=5,byrow=T))
g2=g2+1
}
route2=data.frame(route2[-1,])
names(route2)=c("group","long","lat","number","city")
route2_copy=route2
route2_copy[,1]=as.double(sapply(route2['group'],as.character))
route2_copy[,2]=as.double(sapply(route2['long'],as.character))
route2_copy[,3]=as.double(sapply(route2['lat'],as.character))
route2_copy[,4]=as.double(sapply(route2['number'],as.character))
t3=ggplot()+
geom_polygon(data=mymapd,aes(x=long,y=lat,group=group),color="grey60",fill="white")+
geom_line(data=route2_copy,aes(x=long,y=lat,group=group,color=number),arrow=arrow(angle=10,length=unit(0.2,"inches"),ends='last',type = 'closed'))+
scale_color_continuous(name='number',breaks=c(0,20,80,160),low = 'blue', high = 'red',guide='colourbar')+
geom_point(data=route2_copy,aes(x=long,y=lat))+
geom_text(aes(x=long,y=lat,label=city),data=route2_copy,color="gray0",size=5)+
ylim(15,55)+
expand_limits()+
theme(
panel.grid = element_blank(),
panel.background = element_blank(),
axis.text = element_blank(),
axis.ticks = element_blank(),
axis.title = element_blank(),
legend.background = element_blank(),
legend.position='right',
legend.title = element_text(colour='grey30',size=16),
legend.text = element_text(colour="black", face = "bold",size=16),
# legend.justification=c(0,0), # 这个参数设置很关键
# legend.position=c(0.05,0.1),
plot.margin = unit(c(0,0,0,0),"cm"),
legend.key.size=unit(1.5,'cm')
)
t3
##次数50次以上的订单路线图##
data4=read.table(file="50次以上订单路线1.txt",header=T,sep=',')
data4=as.matrix(data4)
route3=matrix(nrow=1,ncol=5)
g3=1
for(i in 1:dim(data4)[1])
{
for (j in 1:dim(citydata)[1])
{
if (citydata[j,1]==data4[i,1])
{
long1=citydata[j,2]
lat1=citydata[j,3]
}
if (citydata[j,1]==data4[i,2])
{
long2=citydata[j,2]
lat2=citydata[j,3]
}
}
for(h in 1:dim(routenumber)[1])
{
if (routenumber[h,1]==data4[i,1] & routenumber[h,2]==data4[i,2])
{
number1=routenumber[h,3]
}
}
route3=rbind(route3,matrix(c(g3,long1,lat1,number1,data4[i,1],g3,long2,lat2,number1,data4[i,2]),nrow=2,ncol=5,byrow=T))
g3=g3+1
}
route3=data.frame(route3[-1,])
names(route3)=c("group","long","lat","number","city")
route3_copy=route3
route3_copy[,1]=as.double(sapply(route3['group'],as.character))
route3_copy[,2]=as.double(sapply(route3['long'],as.character))
route3_copy[,3]=as.double(sapply(route3['lat'],as.character))
route3_copy[,4]=as.double(sapply(route3['number'],as.character))
p=ggplot()+
geom_polygon(data=mymapd,aes(x=long,y=lat,group=group),color="grey60",fill="white")+
geom_line(data=route3_copy,aes(x=long,y=lat,group=group,color=number),arrow=arrow(angle=10,length=unit(0.2,"inches"),ends='last',type = 'closed'))+
scale_color_continuous(name='number',breaks=c(0,20,80,160),low = 'blue', high = 'red',guide='colourbar')+
geom_point(data=route3_copy,aes(x=long,y=lat))+
geom_text(aes(x=long,y=lat,label=city),data=route3_copy,color="gray0",size=5)+
ylim(15,55)+
expand_limits()+
theme(
panel.grid = element_blank(),
panel.background = element_blank(),
axis.text = element_blank(),
axis.ticks = element_blank(),
axis.title = element_blank(),
legend.background = element_blank(),
legend.position='right',
legend.title = element_text(colour='grey30',size=16),
legend.text = element_text(colour="black", face = "bold",size=16),
# legend.justification=c(0,0), # 这个参数设置很关键
# legend.position=c(0.05,0.1),
plot.margin = unit(c(0,0,0,0),"cm"),
legend.key.size=unit(1.5,'cm')
)
# ====输出图形====
png('~/test001.png',width=1200,height=1000,units="px",bg = "transparent")
print(p)
dev.off()
模块3：以前的一些练习代码
rm(list=ls())
#==========Start==============
#==========基础操作===========
unique() #去重
duplicated() #删除重复值
getwd() #获取当前路径
dirname(parent.frame(2)$ofile) #获取当前执行R文件所在目录
#==========生成序列=========
x<-1:10
rep(1:4, c(2,1,2,1))
rep(1:4, each = 2, len = 4)
rep(1:4, each = 1, times = 3)
rep(1:4,c(1,2,3,4))
seq(1,9,by = 1)
paste(c('a','b','c'),rep(1:3,rep(3,3)),sep = "")
rep(1:3,each=3,times=2)
a=c("a","b","C");b=1:3;c=1:2
expand.grid(a,b,c)
#==========R中''和""的区别=============
"'"
'"'
'\"'
#==========生成随机数===========
runif(5)
rnorm(4,2.5)
rnorm(10) #生成的随机数，符合mean=0,sd=0的标准均差
runif(10,-5,1) #随机生成器
sample(-5:1,size=10,replace = T) #随机抽样
#==========head和tail==============
a<-1:10
head(a,1)
tail(a,1)
#==========replace==========
set.seed(123)
base=c('a','t','c','g')
n=30
dna=sample(base,n,T,c(0.2,0.2,0.3,0.3))
dna=paste(dna,collapse = '')
rna=chartr('t','u',dna)
#==========利用Which %in%求交集=========
A<-data.frame(
name=c("Devin","Edward","Lulu","Jeneen"),
age=c(30,33,29,32),
score=c(95,99,90,88),
class=c(1,2,1,2),
gender=c("M","M","F","F")
)
A
if(which("class"%in%cn)){
match(c("class","score"),cn)
}
which(cn%in%c("class","score"))
B=apply(A,2,function(x){as.factor(x)})
B
#=========开三次方================
a=c(1,2,-1,4)
b=as.matrix(a)
b^(1/3)
x=b
abs(x)^(1/3)*sign(x)
#==========笛卡尔积==========
a=c(2014,2015)
b=c(1:12)
outer(paste(a,'年',sep=''),paste(b,'月',sep=''),paste,sep="")
paste(outer(a,b,paste,sep="年"),'月',sep="")
#==========Base:assign、Eval摘除子变量==============
dat<-seq(1,25,by=1)
dat<-matrix(dat,5,5)
for (i in 1:5){
assign(paste("data",i,sep=""),dat[,i])
}
for(i in 1:2){
eval(parse(text=paste("t","_",i,"=mtcars[seq(24*i-23,24*i),]",sep="")))
}
eval(parse(text = "c(1,2)"))
x1<-1:3;x2=2:5;x3=12:20
for(i in 1:3){
eval(parse(text=paste("x",i,"=sum(x",i,"^2)",sep="")))
}
for(i in c("x1","x2","x3")){
assign(paste(i,"new",sep=""),sum(get(i)^2))
}
x1;x2;x3
#=========switch================
require(stats)
centre <- function(x, type) {
switch(type,
mean = mean(x),
median = median(x),
trimmed = mean(x, trim = .1))
}
x <- rcauchy(10)
centre(x, "median")
gender <- sample(c('F','M','Unknow'), size = 100000, replace = TRUE)
gender3 <- factor(gender, levels = c('F','M','Unknow')) #自定义switch函数返回值
s <- function(case) switch(case,'Female','Male','Unknow')
system.time(gender4 <- sapply(as.numeric(gender3),s))
X=c('F','M','Unknow')
switch (X,'Female','Male','Unknow')
ccc <- c("b","QQ","a","A","bb")
# note: cat() produces no output for NULL
for(ch in ccc)
cat(ch,":", switch(EXPR = ch, a = 1, b = 2:3), "\n")
for(ch in ccc)
cat(ch,":", switch(EXPR = ch, a =, A = 1, b = 2:3, "Otherwise: last"),"\n")
#=========within==============
score<-round(runif(100000,min=40,max=92))
system.time(score<-within(data.frame(score),{
score4<-''
score4[score<60]<-'不及格'
score4[score>=60&score<80]<-'合格'
score4[score>=80]<-'优秀'
}))
score
#=========列转factor=================
transpose_A<-function(x){
t=as.factor(A[,x])
t=as.data.frame(t)
colnames(t)<-x
return(t)
}
A<-data.frame(
name=c("Devin","Edward","Lulu","Jeneen"),
age=c(30,33,29,32),
score=c(95,99,90,88),
class=c(1,2,1,2),
gender=c("M","M","F","F")
)
cn=colnames(A)
B=sapply(list(cn)[[1]],transpose_A)
str(as.data.frame(B))
#==========创建空数据框=====
data=data.frame(matrix(NA,3,4))
data
data$X1=c(1:3)
data$X2=c(2:4)
data
#==========数据框操作========
#数据框赋值
b<-data.frame('a',1,2,3,4);b
t<-c("a","b","c")
w<-"001"
tw<-data.frame(x=paste(t,sep="",collapse = ","),y=w);tw
paste(t,sep="",collapse = ",")
#==========删除指定条件行=====
dat<-data.frame("x"=c(1,2,3),"y"=c(11,12,13),"z"=c(111,222,333))
dat
dat[which(!dat$x%in%c(1,3)),]
dat[-which(dat$x%in%c(1,3)),]
subset(dat,!dat$x%in%c(1,3))
split(dat,dat$x) #分组
#==========求行平均===========
dat<-data.frame(
'星期1'=c(1,2,3,4,5),
'星期2'=c(2,3,4,5,6)
)
row.names(dat)<-c('a','b','c','d','e')
dat
rowMeans(dat[1,])
apply(dat, 1, mean)
dat
rowSums(dat)
#==========求行汇总===========
require(stats)
x <- matrix(runif(100), ncol = 5)
group <- sample(1:8, 20, TRUE)
(xsum <- rowsum(x, group))
## Slower versions
tapply(x, list(group[row(x)], col(x)), sum)
t(sapply(split(as.data.frame(x), group), colSums))
aggregate(x, list(group), sum)[-1]
dat<-data.frame(
'星期1'=c(1,2,3,4,5),
'星期2'=c(2,NA,5,6,NA)
)
dat
s<-list()
length(s)<-nrow(dat)
for (i in 1:nrow(dat)){
# s[i]<-sum(dat[i,],na.rm = T)
dat$a[i]<-i
}
dat
unlist(s)
#==========累计求和方法============
A<-c(1,2,3,4)
B<-c("a","b","c","c")
temp<-tapply(A,B,cumsum)
temp
t=data.frame(name=c("b","a","b","a","a"),fenshu=1:5);t
new=data.frame(t[order(t[,1]),],p=unlist(tapply(t[,2],t[,1],cumsum)))
new
install.packages("data.table")
require(data.table)
t=data.table(name=c("b","b","b","a","a"),fenshu=1:5)
t[,cumsum(fenshu),by=name]
#==========数据框合并_merge=====================
ID1<-c(1,2,3,4)
name<-c("Jim","Tony","Lisa","Tom")
ID2<-c(3,1,2,4)
score<-c(89,22,78,78)
student1<-data.frame(ID1,name)
student2<-data.frame(ID2,score)
total_student<-merge(student1,student2,by.x = "ID1",by.y="ID2")
total_student
#==========合并：tapply========
b<-c(rep(c("A","B","C","D"),2),"A","B");
c<-2:11
dg<-data.frame(b,c)
tapply(dg$c,dg$b,print)
#==========合并：dplyr===============
#install.packages("dplyr")
#install.packages("tidyr")
library(reshape2)
library(dplyr)
library(Matrix)
library(arules)
b<-c(rep(c("A","B","C","D"),2),"A","B")
c<-2:11
dg<-data.frame(b,c)
dg
dg[,'b']
as(split(dg$b,dg$c),"transactions")
dg
df<-dg%>%
group_by(b)%>%
dplyr::summarize(
c=paste(c,collapse = ",")
)
df
apply(df,2,function(x){unlist(strsplit(x,","))})
tapply(dg$c,dg$b,print)
tapply(dg$c,dg$b,function(x){paste(x,sep="",collapse = ",")})
#==========三种方式实现类数据透视表功能===================
a<-c(rep("F",3),rep("E",3),rep("G",3))
b<-c(rep(c("A","B","C"),3))
c<-2:10
dg<-data.frame(a,b,c)
dg
#tapply
dg$a=as.factor(dg$a)
dg$b=as.factor(dg$b)
tapply(dg$c,list(dg$b,dg$a),sum)
# tapply(dg$c,list(dg$b,dg$a),print)
#spread
library(tidyr)
spread(dg,a,c)
#recast
library(reshape2)
recast(dg,b~a)
#示例
transet=data.frame(
a=paste("mac",rep(1:3,each=3),sep = ""),
b=rep(c("性别","年龄","教育水平"),3),
c=c("女","28","硕士","男","33","博士","男","24","本科")
)
transet
spread(transet,b,c)
dcast(transet, a~b, value.var = 'c')
#==========transform============
library(plyr)
library(ggplot2)
# 使用stringsAsFactors=F来防止data.frame把向量转为factor
apache = data.frame(httpCode=c(200,200,200,404,404,500),
time=c(100,111,210,10,10,500),
api=c('index','index','logout','show','show','index'),
stringsAsFactors=F)
head(apache)
ddply(apache,.(api),summarize,number=length(api))
a<-ddply(apache,.(api,httpCode),summarize,number=length(api))
b <- ddply(a,
.(),
.fun=function(x){
transform(x, percentage=with(x,ave(number,api,FUN=sum)/sum(number)))
})
ggplot(b,aes(x=reorder(api,percentage),y=percentage,fill=factor(httpCode))) +
geom_bar() +
scale_y_continuous(labels = percent_format()) +
coord_flip()
#==========重复数据处理========
#提取重复数据
x <- rep(c("A", "B"), each = 5)
y <- c(110,110,111,112,111,113,114,114,115,113)
z <- c(1,2,1,1,1,1,1,2,1,1)
dat <- data.frame(x=x, y=y, z=z)
dat
cumsum(rle(dat$y)$lengths)
dat[-cumsum(rle(dat$y)$lengths), ]
dat[which(diff(dat$y)==0),]
#提取重复数据
#方法1
abc <- data.frame(x=c(1,2,1,3,3),y=c(1,3,1,0,0));abc
abc
t=abc[duplicated(abc),];t
merge(abc,t,all = F)
#方法2
library(sqldf)
#重复数据
sql='select * from abc where x in (select x from abc group by x having(count(1)>1))'
sqldf(sql)
#多余的重复数据
sql='select * from abc where x not in (select max(x) from abc group by x having(count(1)>1))'
sqldf(sql)
dat=data.frame(x=c(1,3,4),y=c(3,1,5))
# library(dplyr)
library(plyr)
tt=apply(dat,1,function(x){x[rank(x)]})
tt=t(tt);tt
tt[-duplicated(as.data.frame(tt)),]
#==========重复内容求和===========
dat=data.frame(a=c(rep("A",2),rep("B",3)),b=1:5,c=2:6,d=3:7)
dat
which.min(dat$b)
min(dat$b)
library(dplyr)
group_by(dat,a)%>%
summarise(min(b))
tapply(dat$b, dat$a, min)
#==========创建空列表===========
lst=list()
length(lst)=10
#示例
data=list()
length(data)<-10
for (i in 1:10){
data[[i]]<-c(1:i)
}
data
#==========列表删除某一元素============
a=list(a=c(1,2,3),b=NULL)
a$c=c(1,2)
a$b=NULL
#==========列表：生成指定============
#列表1
cv=function(x,Z=10,seed=888){
Z=Z
t1=rep(1:Z,ceiling(x/Z))[1:x]
set.seed(seed)
t2=sample(t1,x)
mm=list()
for(i in 1:Z){
mm[[i]]=(1:x)[t1==i]
}
return(mm)
}
tt=cv(100)
#列表2
cv1=function(n,Z=10,seed=1){
z=rep(1:Z,ceiling(n/Z))[1:n]
set.seed(seed)
z=sample(z,n)
mm=list()
for(i in 1:Z){
mm[[i]]=(1:n)[z==i]
}
return(mm)
}
cv1(100)
#==========生成滞后一项========
a = c(1,2,3,4,5)
b = lag(a)
#==========生成二维序列=========
a<-c("a","b","c")
b<-1:2
c<-1:3
list(a=a,b=b,c=c)
dt<-expand.grid(a,b,c)
apply(dt,1, function(x){paste(x,sep="",collapse = "")})
library(help = "base")
#==========时间操作============
library(lubridate) #时间日期包
library(chron)
#数值转时间
as.Date("20150807","%Y%m%d")
d<-42570
as.Date(d,origin="1900-01-01")
today()
now()
as.Date(now(),"%Y%m%d")
dtimes = c("2002-06-09 12:45:40","2003-01-29 09:30:40",
"2002-09-04 16:45:40","2002-11-13 20:00:40",
"2002-07-07 17:30:40")
dtimes
dtparts = t(as.data.frame(strsplit(dtimes,' ')))
row.names(dtparts) = NULL
thetimes = chron(dates=dtparts[,1],times=dtparts[,2],
format=c('y-m-d','h:m:s'))
thetimes
dts = c("2005-10-21 18:47:22","2005-12-24 16:39:58",
"2005-10-28 07:30:05 PDT")
as.POSIXlt(dts)
dts = c(1127056501,1104295502,1129233601,1113547501,
1119826801,1132519502,1125298801,1113289201)
mydates = dts
class(mydates) = c('POSIXt','POSIXct')
mydates
mydate = strptime('16/Oct/2005:07:51:00',format='%d/%b/%Y:%H:%M:%S')
ISOdate(2005,10,21,18,47,22,tz="PDT")
thedate = ISOdate(2005,10,21,18,47,22,tz="PDT")
format(thedate,'%A, %B %d, %Y %H:%M:%S')
mydate = as.POSIXlt('2005-4-19 7:01:00')
names(mydate)
mydate$mday
#==========时间周期_lubridate包=====================
# install.packages("lubridate")
today=Sys.time()
format(Sys.Date(),"%U")
#==========时间差计算_difftime=================
d <- c('2013-12-05 18:43:00','2013-08-23 22:29:00')
difftime(d[2],d[1])
strptime(d, "%Y-%m-%d %H:%M:%S")
difftime(strptime(d, "%Y-%m-%d %H:%M:%S")[2],strptime(d, "%Y-%m-%d %H:%M:%S")[1])
difftime(strptime(d, "%Y-%m-%d %H:%M:%S")[2],strptime(d, "%Y-%m-%d %H:%M:%S")[1],units='secs')
#==========查看源代码============
library(arules)
getAnywhere(apriori)
fix(apriori)
#==========查看帮助文档_vignette=======
vignette("grid") #查看小文品
#==========读入文件============
getwd()
choose.dir()
list.files()
#csv
read.csv()
fread()
#txt
read.table()
readLines() #读入不规则文本
#SPSS
library(foreign)
dat<-read.spss("~/huigui.sav")
#xlsm
library(xlsx)
read.xlsx()
#readxl
library(readxl)
read_excel()
#RODBC
RODBC::odbcConnectExcel2007()
#==========写出=======
write.csv()
write.table()
#保存图片
file()
#==========输出中换行================
paste("a","b",collapse = " ",sep="")
cat(c("ab","\n","\nb"))
plot(1,ylab=expression(italic("toto")["subscript"]),xlab=expression(italic("toto")^"subscript"))
text<-c(substr("你是最优秀的",1,nchar("你是最优秀的")/2),
"\n",
paste('\n',substr("你是最优秀的",nchar("你是最优秀的")/2+1,nchar("你是最优秀的")),sep='')
)
cat(text)
#==========文件夹系统============
# 当前的目录
getwd()
# 查看当前目录的子目录
list.dirs()
#查看当前目录的子目录和文件
dir()
# 查看指定目录的子目录和文件。
dir(path="./figure/")
#==========文件操作_file=============
path = 'J:/lab/EX29 --在R语言中进行文件（夹）操作'
setwd(path)
cat("file A\n", file="A") #创建一个文件A，文件内容是'file A','\n'表示换行，这是一个很好的习惯
cat("file B\n", file="B") #创建一个文件B
file.append("A", "B") #将文件B的内容附到A内容的后面，注意没有空行
file.create("A") #创建一个文件ZWZA, 注意会覆盖原来的文件
file.append("A", rep("B", 10)) #将文件B的内容复制10便，并先后附到文件A内容后
file.show("A") #新开工作窗口显示文件A的内容
file.copy("A", "C") #复制文件A保存为C文件，同一个文件夹
dir.create("tmp") #创建名为tmp的文件夹
file.copy(c("A", "B"), "tmp") #将文件夹拷贝到tmp文件夹中
list.files("tmp") #查看文件夹tmp中的文件名
unlink("tmp", recursive=F) #如果文件夹tmp为空，删除文件夹tmp
unlink("tmp", recursive=TRUE) #删除文件夹tmp，如果其中有文件一并删除
file.remove("A", "B", "C") #移除三个文件
file.rename(from = ,to = )
#==========文件清单之list.files===========
files<-list.files()
files
split(files,"")
as.data.frame(files)
files<-getSampleFiles()
#==========reshape包：melt==============
library(reshape)
a<-c(rep(2007,4),rep(2008,3),rep(2009,3));a
b<-c(rep(c("A","M","F","D"),2),"A","B");b
c<-2:11
de<-data.frame(a,b,c)
#对应的包是cast
cast(de,a~b)
melt(de,id="b")
chisq.test(c(335, 125, 160), p=c(9,3,4)/16)
help(chisq.test)
chisq.test(rbind(c(335, 125, 160), c(9,3,4)*sum(335, 125, 160)/16))
rbind(c(335, 125, 160), c(9,3,4)*sum(335, 125, 160)/16)
#==========reshape包：melt、dcast、acast==============
library(reshape2)
tes<-data.frame(x=rep(c("A","B","C","D"),c(6,6,6,6)),y=1:24)
tes
unstack(tes,y~x)
#reshape常用方法：melt、dcast、acast
library(reshape2)
library(reshape)
ID=1:8
md<-data.frame(ID=rep(1:4,c(2,2,2,2)),
Ti=rep(1:2,4),
Td=paste("X",rep(1:2,c(4,4)),sep=""),
Val=1:8)
cast(md,ID~Td)
dcast(md,ID~Td,mean)
#==========melt多列揉两列=================
library(dplyr)
library(reshape)
library(xlsx)
library(readxl)
rm(list = ls())
dat=read_excel('~/R日常数据集/多列揉两列/Cost.xlsx',sheet= 2)
colnames(dat)[2]="省份"
colnames(dat)[3:ncol(dat)]=paste("x",colnames(dat)[3:ncol(dat)],sep="")
attributes(dat)
str(dat)
head(dat)
dg=transform(dat,fq=c(1:nrow(dat)))
dt=melt(dg,id.vars = c("类别","省份"))
#e.g
head(melt(tips))
names(airquality) <- tolower(names(airquality))
melt(airquality, id=c("month", "day"))
names(ChickWeight) <- tolower(names(ChickWeight))
melt(ChickWeight, id=2:4)
#==========plot画布============
par(mfrow=c(2,3)) #设置画布,2行3列
mat=matrix(c(1:4,5,5),nrow=3,byrow = T)
mat
layout(mat) #对图形装置（device）按照矩阵进行分割
usr <- par("usr") #获取坐标
#==========par参数设置==========
par(mar=c(5,3,2,2))
# c(bottom, left, top, right)，mar是图形上下左右边缘距离
par(mai=c(2,1,2,2))
# c(bottom, left, top, right)，mai是图形空白边界
par(mgp=c(3,1,0))
# c(title,axis,axis_label)，mpg是针对坐标轴标题、坐标轴标签和坐标轴
par(tck=0.01)
# 其中tck，是刻度线正反向。
opar <- par(no.readonly=TRUE)
# 保存原有的设置
par(lty=2,pch=3,lwd=3,pty)
#lty:line type 线类型;pch：pie 绘制符号类型；lwd:line width 线宽；pty:绘图区域类型
#==========plot示例1==========
windowsFonts(H=windowsFont('华文行楷'))
windows(width=5,height=5)
par(mar=rep(0,4)+0.1)
plot(1,type = 'n',ann=F,axes=F,xlim=0:1,ylim=0:1)
text(0.25,0.80,'test',family='H',cex=5,xpd=T)
text(0.6,1,'test',family='H',cex=5,xpd=T)
text(0.45,0.75,'ppp',family='H',cex=6,xpd=T)
#==========plot相关============
x1<-1:1000
#常规画图
plot(x1,x1^(1/3),type="l",lty=2,lwd=3)
#lty点之间的间隔；lwd线条宽度
#不画X轴
plot(x1,x1^(1/3),type="l",lty=2,lwd=2,xaxt="n")
axis(side = 1,at = c(1,100,900))
axis(side=1,at=c(1,100,900),labels=c(1,9,10))
points(x1,x1^(1/2.5),type="l",lty=1,lwd=3)
points(x1[1:200],x1[1:200]^(1/2.5),type="l",lty=1,lwd=3)
c<-c(7,15,36,39,40,41,50)
quantile(c)
boxplot(quantile(c))
library(rJava)
library(xlsx)
#==========plot绘图案例1============
weight = c(115,117,120,123,126,129,132,135,139,142,146,150,154,159,164)
height = c(58,59,60,61,62,63,64,65,66,67,68,69,70,71,72)
fit2 = lm(weight~height+I(height^2))
plot(height,weight,'p')
points(60,125)
text(60,125,labels = "2000")
abline(fit2)
summary(fit2)
as.POSIXct("2015-1-1")
#==========plot背景
transet=data.frame(
year=c(2000+2:15),
poi=runif(14,50,100)
)
plot(transet$year,transet$poi,type = "p",)
lines(transet$year,transet$poi)
#==========ggplot======================
#ggplot在应用facet时，标题在图形居中显示
#方法：theme中plot.title=element_text(hjust=0,5)
library(ggplot2)
#散点图
d <- ggplot(diamonds, aes(carat)) + xlim(0, 3)
d + stat_bin(aes(ymax = ..count..), binwidth = 0.1, geom = "area")
d + stat_bin(
aes(size = ..density..), binwidth = 0.1,
geom = "point", position="identity"
)
d + stat_bin(
aes(y = 1, fill = ..count..), binwidth = 0.1,
geom = 'tile', position='identity'
)
#柱状图
library(ggplot2)
PV <- c("湖南","湖北","山西")
GDP <- c(6,8,15)
mydata <- data.frame(PV=PV,GDP=GDP)
ggplot(mydata,aes(x=PV,GDP))+geom_bar(stat = "identity")
#直方图
rm(list=ls())
set.seed(seed = 1)
data=rnorm(100)*2+6
layout(matrix(c(1,2),1),widths = c(5,1))
par(mar=c(4,5,4,0),mgp=c(2.5,0.8,0))
p=hist(data,col='white',xaxt='n',yaxt='n',
border='white',breaks=20,
xlab = '',ylab = '',main='')
cs=p$counts/max(p$counts)
breaks=round(seq(0,max(p$counts),len=6)[-6])
red=cs
green=1-cs
blue=0
par(new=T)
hist(data,col=rgb(red,green,blue),breaks = 20,
yaxt='n',border='white',ylab='count',
main='')
axis(2,las=2)
par(mar=c(8,0,8,3.3),mgp=c(2.5,0,0.2))
color2=rgb(seq(0,1,len=length(breaks)),
seq(1,0,len=length(breaks)),
0)
image(x=1,y=0:length(breaks),
z=t(matrix(breaks))*1.001,
col=color2,axes=F,xlab='')
mtext(side=3,line=0,'count')
axis(4,at=1:length(breaks)-1,labels = breaks,
las=2,col='white')
#==========ggplot设置Scale刻度================
library(ggplot2)
data(diamonds)
head(diamonds)
set.seed(42)
dat=diamonds[sample(nrow(diamonds),1000),]
head(dat)
p=ggplot(diamonds,aes(carat,price,shape=cut,colors=cut))
p=p+geom_point()
p
#scale_shape_manual()、scale_colour_hue()
bks<-c(0, 2000, 4000,6000, 8000, 10000)
p + scale_x_continuous("price", breaks = bks, labels = bks)
#==========ggplot之density用法=============
mydat<-read.table("~./mydat.txt",header = T)
head(mydat)
mydat[1:100,]
mydat<-na.omit(mydat)
density(mydat[1:61487,])
p<-ggplot(mydat)
p+geom_density(aes(x=x,y=..count../sum(..count..)))
p=ggplot(mydat)
p+geom_density(aes(x=x,y = ..density..))
p=ggplot(mydat)
p+geom_density(aes(x=x,y = ..scaled..))
p=ggplot(mydat)
p+geom_histogram(aes(x=x,y = ..ndensity..))
plot(density(c(-20, rep(0,98), 20)), xlim = c(-4, 4)) # IQR = 0
c(-20, rep(0,98), 20)
density(c(-20, rep(0,98), 20))
chr="sample.file=sample.txt"
str(chr)
arg=unlist(strsplit(chr,"="));arg
paste(arg[1],arg[2],sep = "=====",collapse = "")
ss<-c("asdf_dfgh_sd")
ss<-strsplit(ss,"_")
unlist(ss)
paste(1,2,sep = "===")
#==========ggplot多图=================
library(gridExtra)
grid.arrange(x,y,nrow=2,ncol=1)
#==========ggplot_坐标轴反转=================
# install.packages("cowplot")
library(reshape2)
library(reshape)
library(ggplot2)
library(cowplot)
dat=read.csv("~/aa.csv",header = T)
head(dat)
New_dat<-melt(data = dat,id=c('TARGET'))
head(New_dat)
p=ggplot(data=New_dat,mapping = aes(x=TARGET,y=variable,fill=value))
p=p+geom_tile()
#ggdraw中switch_axis_position可以选择坐标轴
ggdraw(switch_axis_position(p + theme_gray(), axis = 'y'))
ggdraw(switch_axis_position(p + theme_gray(), axis = 'xy',keep = "xy"))
p+geom_raster()
#==========gridExtra包=============
# install.packages("gridExtra")
library(gridExtra)
#==========grid包：曲线绘制在一个页面===========
grid.newpage() ##新建页面
pushViewport(viewport(layout = grid.layout(length(st_name),1)))
vplayout <- function(x,y){
viewport(layout.pos.row = x, layout.pos.col = y)
}
#==========plotrix:====================
# x-values
x <- 1:4
# small y-values with corresponding standard errors
meansarr <- c(14.9, 18.2, 14.5, 18.3)
searr <- c(0.47, 1.27, 1.22, 0.49)
# large values
meanslay <- c(36.4, 39.0, 35.3, 38.6)
selay <- c(0.51, 0.34, 0.57, 0.40)
library(plotrix)
# plot small values
plot(x, meansarr, ylim=c(12, 30), axes=F, type="b", xlab="", ylab="Day")
arrows(x, meansarr-searr, x, meansarr+searr, code = 3, angle = 90,
length = 0.03)
box()
# x-axis
axis(1, tck=0.01, las=1, at=1:4,
labels=c("1998", "1999", "2002", "2003"), mgp=c(3, 0.5, 0))
# y-axis
axis(2,at=c(12, 14, 16, 18, 20, 24, 26, 28,
30),labels=c("12","14","16","18","20", "34","36","38","40"))
# break axis
axis.break(2, 22, style="zigzag")
# add large values to same plot
par(new=TRUE)
plot(x, meanslay, ylim=c(30, 40), type="b", xlab="", ylab="Day", axes=F)
arrows(x, meanslay-selay, x, meanslay+selay, code = 3, angle = 90,
length = 0.03)
#==========eqscplot绘制垂直误差线==============
library(MASS)
X <- scale(mvrnorm(20, c(2,2), matrix(c(1,0.5,0.5,1),2,2)))
eqscplot(X)
X.cov <- cov(X)
X.ed <- eigen(X.cov)
proj <- X.ed$vec[,1] %*% t(X.ed$vec[,1])
y <- t(proj %*% t(X))
abline(a=0,b=X.ed$vec[2,1]/X.ed$vec[1,1])
arrows( X[,1], X[,2], y[,1],y[,2], length = 0.05, col = "blue")
#==========ggplot2案例1====================
library(ggplot2)
date <- c("2011-09-19","2011-09-20","2011-09-21",
"2011-09-22","2011-09-23","2011-09-26","2011-09-27")
price <- c(100,110,105,115,120,115,125)
tmp <- data.frame(date,price)
head(tmp,3)
tmp$date <- as.Date(tmp$date)
p <- ggplot(tmp,aes(tmp$date,tmp$price))+geom_line()
p+labs(title="Simple price plot",x="Date",y="Price")
p+xlab('时间')
#==========ggplot绘多条折线图之melt转换数据==================
library(ggplot2)
library(reshape)
p <- ggplot(mtcars, aes(x = wt, y = mpg)) + geom_point()
p + geom_vline(aes(xintercept = wt))
library(ggplot2)
library(reshape)
test_data <- data.frame( var0 = 100 + c(0, cumsum(runif(49, -20, 20))),
var1 = 150 + c(0, cumsum(runif(49, -10, 10))),
date = seq.Date(as.Date("2002-01-01"), by="1 month", length.out=100))
test_data
test_data_long <- melt(test_data, id="date") # convert to long format
#test_data_long
ggplot(data=test_data_long, aes(x=date, y=value, colour=variable)) + geom_line()
rm(list = ls())
#==========plotly：ggplotly交互图============
install.packages("plotly")
library(plotly)
ggplotly
#==========绘制中国地图_plot======================
#got the london_sport.shx and london_sport.dbf files in the same folder?
#You need all three to make a "Shapefile".
par(mar=c(0,0,0,0)+0.1,xpd=TRUE)
library(maptools)
x=readShapePoly('C:/Users/zhengweilin/Documents/中国地图GIS数据/maps/bou2/bou2_4p.shp')
x=readShapePoly('C:/Users/zhengweilin/Documents/bou2_4p.shp')
x=readShapePoly('C:/Users/zhengweilin/Documents/中国地图GIS数据/maps/bou2/bou2.shp')
getColor=function(mapdata,provname,provcol,othercol)
{
f=function(x,y) ifelse(x %in% y,which(y==x),0)
colIndex=sapply(mapdata@data$NAME,f,provname)
fg=c(othercol,provcol)[colIndex+1]
return(fg)
}
provname=c("北京市","天津市","上海市","重庆市")
provcol=c("red","green","yellow","purple")
plot(x,col=getColor(x,provname,provcol,"white"))
#==========Github和baidumap=============
# install.packages("devtools")
library(devtools)
# install_github('badbye/baidumap')
# install_github('lchiffon/REmap')
library(REmap)
library(baidumap)
getCoordinate('北京大学') # json
getCoordinate('北京大学', output='xml') # xml
getCoordinate('北京大学', formatted = T) # character
getCoordinate(c('北京大学', '清华大学'), formatted = T) # matrix
p<-getBaiduMap(c(116.354431,39.942333))
#绘制百度地图
library(ggmap)
ggmap(p)
#==========文本处理之substring==============
a<-"world"
paste(unlist(strsplit(a,""))[1:3],sep="",collapse = "")
substring(a,c(2))
#==========文本处理之strsplit用法===============
sa<-c("1234512","1234567")
sd<-as.data.frame(strsplit(sa,""))
colnames(sd)<-c("a","b")
se<-merge(sd[6:7,1],sd[7:6,2])
paste(se$x,se$y,sep="",collapse = " ")
c<-"hello
world"
data.frame(unlist(strsplit(c,"\\n")))
#==========stringr的分割线========
#在R中关于反斜杠\的替代处理办法
library(stringr)
a<-"aaa111\\\\aa\\\aaa\a"
a<-"a\aab\\c\\d\\e"
b<-gsub("[^[:graph:]]","",a);b
gsub("\\", '', b, fixed=TRUE)
gsub("\\\\","", a)
a<-str_replace_all(a,"([\\])","")
str_replace_all(a,"([\\])","")
strsplit(a,"\\\\")
gsub("\\", "", a, fixed=TRUE)
gregexpr("([\\])",a)
gsub("Hmisc::escapeRegex","",a)
gsub("Hmisc::escapeBS","",a)
gsub("([\\])","", "C:\subfolder")
#==========stringr练习1========
library(stringr)
t=as.character(Sys.time());t
strsplit(t,"\\s")
??rainbow()
#==========stringr练习2========
strings <- c(" 219 733 8965", "329-293-8753 ", "banana", "595 794 7569",
"387 287 6718", "apple", "233.398.9187 ", "482 952 3315",
"239 923 8115 and 842 566 4692", "Work: 579-499-7527", "$1000",
"Home: 543.355.3679")
phone <- "([2-9][0-9]{2})[- .]([0-9]{3})[- .]([0-9]{4})"
str_extract(strings, phone)
str_match(strings, phone)
# Extract/match all
str_extract_all(strings, phone)
str_match_all(strings, phone)
#==========str_extract_all提取正则匹配========
library(stringr)
shopping_list <- c("apples x4", "bag of flour", "bag of sugar", "milk x2")
str_extract(shopping_list, "\\d")
#==========字符串内字符频率统计============
abc<-"abc,abca"
#strsplit计算分段数
t<-strsplit(abc,"a")
length(t)
#stringr频率统计
library(stringr)
str_count(abc,"a")
#正则
attr(gregexpr("a",abc)[[1]],"match.length")
a <- "aggcacggaaaaacgggaataacggaggaggacttggcacggcattacacggagg"
regexpr("ag",a)
gregexpr("ag",a)
gregexpr("a.g",a)
attr(gregexpr("a.g",a)[[1]], "match.length") #提取子模式长度
#==========正则_Grep==========
test<-c("one","long","oner","dead")
test[grep('[on]',test)]
test[grep('[on|ed]',test)]
grep('[on|ed]',test,value=T)
#value=T返回字符、invert表示反选
grep("o",test,value = T,invert =F)
gregexpr('o|n',test)
regmatches(test,gregexpr('o|n',test))
gregexpr("o","zoo")
one<-1
get(grep("^one$",test,value=T))
one<-10000
get(grep("^one$",test,value=T))
st<-"s123456"
sr<-paste(unlist(regmatches(st,gregexpr('\\d',st))),collapse = "")
substr("Abcd",2,2)
substring("abcdef", 1:6, 1:6)
x <- c("asfef", "qwerty", "yuiop[", "b", "stuff.blah.yech")
substring(x, 1, 5:6)
substr(x, 2, 5:6)
substring(x, 2) <- c("..", "+++")
x
#练习001
f="1-2-(234).xls"
gregexpr('\\((\\d.+)\\)',f)
regmatches(f,gregexpr('\\((\\d.+)\\)',f))
#==========正则_取子表达式=============
# 正则取子表达式
x="time=13422&cardid=23323&cyberzone=wefa"
# t1=regexpr('cardid=(\\d*?)&',x,perl = T)
# t2=gregexpr('cardid=(\\d*?)&',x,perl = T)
t3=regexec('cardid=(\\d*?)&',x)
substr(x,t3[[1]][2],t3[[1]][2]+attr(t3[[1]],"match.length")[2]-1)
regexec('time=(\\d*?)&cardid=(\\d*?)&',x)
#==========数据清洗_取指定条件================
subset(da,da$province %in% c("A","B") )
da$province[grep("A|B",da$province)]
#==========Plyr_arrange排序=======================
dat<-data.frame(a=rep(c(1,2),3),b=rnorm(6))
dat$b
b1<-sort(dat$b,decreasing = T)
b1
dat[order(dat$b,decreasing = F),]
table(dat$a,dat$b)
dat[c(2,6,4),]
library(base)
library(plyr)
arrange(dat,desc(b))
#==========dplyr_分组取Top5的值=========
dat=data.frame(a=c(rep("A",5),rep("B",3)),b=runif(8,1,10))
dat
library(dplyr)
group_by(dat,a)%>%top_n(3)
#min_rank相关
x <- c(5, 1, 3, 2, 2, NA)
row_number(x)
min_rank(x)
dense_rank(x)
percent_rank(x)
cume_dist(x)
#==========dplyr：group_by==============
library(dplyr)
b<-c(rep(c("A","B","C","D"),2),"A","B");
c<-2:11
d<-3:12
dg<-data.frame(b,c,d)
gb<-group_by(dg,b)
gb
summarise(gb,c=paste(c,collapse = ","))
summarise(gb,d=sum(d))
#==========合并：tapply========
b<-c(rep(c("A","B","C","D"),2),"A","B");
c<-2:11
dg<-data.frame(b,c)
tapply(dg$c,dg$b,print)
#==========合并：dplyr===============
#install.packages("dplyr")
#install.packages("tidyr")
library(reshape2)
library(dplyr)
library(Matrix)
library(arules)
b<-c(rep(c("A","B","C","D"),2),"A","B")
c<-2:11
dg<-data.frame(b,c)
dg[,'b']
as(split(dg$b,dg$c),"transactions")
dg
df<-dg%>%
group_by(b)%>%
dplyr::summarize(
c=paste(c,collapse = ",")
)
df
apply(df,2,function(x){unlist(strsplit(x,","))})
tapply(dg$c,dg$b,print)
tapply(dg$c,dg$b,function(x){paste(x,sep="",collapse = ",")})
#==========tidyr:拆分===================
library(tidyr)
df
df%>%
group_by(b)%>%
transform(c= strsplit(c, ","))%>%
unnest(c)
#==========tapply用法===============
a<-c(rep(2007,4),rep(2008,3),rep(2009,3));a
b<-c(rep(c("A","B","C","D"),2),"A","B");b
c<-2:11
da<-as.data.frame(cbind(a,b,c))
colnames(da)<-c("year","province","sale")
#attach连接数据框、detach释放
attach(da)
attributes(da)
factor(province)
aa<-list(year,province)
tapply(sale,province)
tapply(sale,year)
# ??tapply
tapply(sale,list(year,province))
tapply(sale,list(year,province),mean)
detach(da)
#官方示例
ind <- list(c(1, 2, 2), c("A", "A", "B"))
table(ind)
ind
tapply(1:3, ind) #-> the split vector
tapply(1:3, ind, sum)
#==========tapply_合并========
b<-c(rep(c("A","B","C","D"),2),"A","B");
c<-2:11
dg<-data.frame(b,c)
dg$c=as.factor(dg$c)
tapply(dg$c,dg$b,print)
tapply(dg$c,dg$b,paste)
tapply(dg$c,dg$b,function(x){paste(x,sep="",collapse = ",")})
#==========dplyr：unite\tidyr：separate==============
library(dplyr)
library(tidyr)
unite
unite_(mtcars, "vs_am", c("vs","am"))
# Separate is the complement of unite
mtcars %>%
unite(vs_am, vs, am)%>%
separate(vs_am, c("vs", "am"))
#==========dplyr：group_by+summarise=====================
head(mtcars)
library(dplyr)
group_by(mtcars,am)%>%
summarise_each(funs(mean))%>%
ungroup
tt<-group_by(mtcars,am)
group_by(mtcars,am)%>%
summarise_each(funs(mean))
#==========dplyr：%>%含义=====================
library(ggplot2)
library(plyr)
library(dplyr)
library(tidyr)
anscombe_tidy <- anscombe %>%
+ mutate(observation = seq_len(n())) %>%
+ gather(key, value, -observation) %>%
+ separate(key, c("variable", "set"), 1, convert = TRUE) %>%
+ mutate(set = c("I", "II", "III", "IV")[set]) %>%
+ spread(variable, value)
# 是管道函数啦，就是把左件的值发送给右件的表达式，并作为右件表达式函数的第一个参数。
# anscombe_tidy <- anscombe %>%mutate(observation = seq_len(n()))
# 以上代码等价于
# anscombe_tidy=mutate(anscombe,observation = seq_len(n()))
#中国式排名
a=c(0.1,0.2,0.3,0.6,0.7,2,0.3,0.1,0.1)
b=unique(a)
c<-data.frame(a)%>%
left_join(data.frame(a=b,d=order(b)),by="a")
c
#生成序列
library(dplyr)
x<-1:10
x%>%lapply(function(x) 1:x)%>%unlist
#==========dplyr：sapply===============
z=list(a=c(1:3),b=c(5:6),c=c(7:11))
data.frame(z=rep(names(z),sapply(z,length)), y=unlist(z))
z=list(c(1:3),c(5:6),c(7:11))
data.frame(x=rep(c(1:length(z)),sapply(z,length)),y=unlist(z))
#==========dplyr：ddply取分类前三======
library(dplyr)
library(plyr)
tes<-data.frame(x=rep(c("A","B","C","D"),c(6,6,6,6)),y=1:24)
tes
ddply(tes,~x,subset,rank(y)<=3)
#==========dplyr练习====================
library(dplyr)
a=c(0.1,0.2,0.3,0.6,0.7,2,0.3,0.1,0.1)
b=unique(a)
c<-data.frame(a)%>%
left_join(data.frame(a=b,d=order(b)),by="a")
c
a<-data.frame(a=a)
c<-data.frame(unique(a),d=order(unique(a)))
merge(c,a,by=c("a"))
left_join(a,c,by="a")
tt<-matrix(c(1:12),nrow=3,byrow=T)
t1<-table(tt)
t2<-as.data.frame(t1)
t2$tt=as.numeric(t2$tt)
colnames(t2)<-c("x","y")
data.frame(x=tt[,1])%>%
left_join(t2,by="x")
tt<-matrix(c(1:12),nrow=3,byrow=T)
t1<-table(tt)
t2<-as.data.frame(t1)
t2$tt=as.numeric(t2$tt)
colnames(t2)<-c("x","y")
t3=data.frame(x=tt[,1])
t2[which(t2$x%in%t3$x),]
#==========tidyr:unnest================
library(dplyr)
library(tidyr)
#==========pipeR===========
install.packages('pipeR')
#==========主成分分析===============
# install.packages("psych")
library(psych)
####主成份分析（Principal Component Analysis，PCA）
####判断主成份个数
fa.parallel(USJudgeRatings[,-1],fa="PC",n.iter=100,
show.legend=FALSE,main="Scree plot with parallel analysis")
#==========协同过滤推荐算法Apriori:transactions===============
library(arules)
dat=read.table("12.txt")
dat<-unique(dat)
# head(dat)
write.table(dat,"12_1.txt",row.names = F)
data=read.transactions("12_1.txt",format="single",cols=c(1,2))
inspect(data)
#==========transactions================
## example 1: creating transactions form a list[示例1：创建交易，形成一个列表]
a_list <- list(
c("a","b","c"),
c("a","b"),
c("a","b","d"),
c("c","e"),
c("a","b","d","e")
)
a_list
## set transaction names[＃设置事务名]
names(a_list) <- paste("Tr",c(1:5), sep = "")
a_list
## coerce into transactions[＃强制交易]
trans <- as(a_list, "transactions")
inspect(trans,5)
a_df3 <- data.frame(TID = c(1,1,2,2,2,3), item=c("a","b","a","b","c", "b"))
a_df3
trans5<- as(split(a_df3[,"item"], a_df3[,"TID"]), "transactions")
inspect(trans5,1)
#==========聚类============
#关于聚类的练习
#聚类的几种方法：离差平方和、最短距离、最长距离、McQuitty相似分析、中间距离、重心
#hclust，R中的聚类函数
require(graphics)
hc <- hclust(dist(USArrests), "ave")
hc
summary(hc)
plot(hc)
plot(hc, hang = -1)
#练习1
x<-c(1,0.846,0.805,0.859,0.473,0.398,0.301,0.382,
0.846,1.000,0.881,0.826,0.376,0.326,0.277,0.277,
0.805,0.881,1.000,0.807,0.380,0.319,0.237,0.345,
0.859,0.826,0.801,1.000,0.436,0.329,0.327,0.365,
0.473,0.376,0.380,0.436,1.000,0.762,0.730,0.629,
0.398,0.326,0.319,0.329,0.762,1.000,0.583,0.577,
0.301,0.277,0.237,0.327,0.730,0.583,1.000,0.539,
0.382,0.415,0.345,0.365,0.629,0.577,0.539,1.000)
names<-c("身高","手臂长","上肢长","下肢长","体重","颈围","胸围","胸宽")
r<-matrix(x,nrow=8,dimnames=list(names,names))
d<-as.dist(1-r);hc<-hclust(d);dend<-as.dendrogram(hc)
nP<-list(col=3:2,cex=c(2.0,0.75),pch=21:22,bg=c("light blue","pink"),
lab.cex=1.0,lab.col="tomato")
addE<-function(n){
if(!is.leaf(n)){
attr(n,"edgePar")<-list(p.col="plum")
attr(n,"edgetext")<-paste(attr(n,"members"),"members")
}
n
}
de<-dendrapply(dend,addE)
par(no.readonly = T)
plot(de,nodePar = nP)
#==========arules:discretize离散数据分类===========
library(arules)
??arules
discretize {arules}
#==========抽取数据之sqldf=====================
head(de)
library(sqldf)
mydat<-sqldf("select * from de where b='F'",row.names=T)
subset(de,de$b %in% "F")
unlist(de$a[which(de$b=="F")])
de$a[grep("F",de$b)]
#==========分组sqldf方法==============
library(dplyr)
library(sqldf)
a<-data.frame(x=1:5,y=letters[c(rep(1:2,2),1)]);a
tapply(a$x,a$y,max)
aggregate(a$x,by=list(a$y),FUN=max)
sqldf("select y,x from a group by y")
summarise(group_by(a,y),n=max(x))
a<-data.frame(x=paste("x",c(1:2,1:3,1:3),sep = ""),y=paste("y",c(1:3,1:5),sep=""),z=1:8);a
b<-tapply(a$z,a$x,max)
b<-aggregate(a$z,by=list(a$x),FUN=max)
a[which(a$x%in%b[,1]&a$z%in%b[,2]),]
rm(a)
rm(b)
#==========RODBC_数据库================
library(RODBC)
odbcDataSources()
ds<-odbcConnect("SQL",uid="sa",pwd="weilin")
data(USArrests)
#将“USArrests”表写进数据库里
sqlSave(ds,USArrests,rownames = "state",addPK = T)
#将数据流保存，这时候打开SQL Server就可以看到新建的USArrests表了
rm(USArrests)
#移除USArrests
sqlTables(ds,tableType = "TABLE")
#列出SQL库中的所有表
sqlFetch(ds,"USArrests",rownames = "state")
sqlQuery(ds,"select * from USArrests")
sqlDrop(ds,"USArrests")
#输出USArrests表中的内容
sqlQuery(ds,"create table Tdat(ID int,Name char(255),School varchar(255))
insert into Tdat(ID,Name,School) values(1,'abc',3)d")
sqlQuery(ds,"alter table Tdat alter column School int")
sqlQuery(ds,"drop table Tdat")
sqlQuery(ds,"insert into USArrests(state,Murder,Assault,UrbanPop,Rape) values('ac',1,2,3,100)")
attr(USArrests,"names")
head(USArrests)
a<-data.frame(state='a',Murder=1,Assault=2,UrbanPop=3,Rape=4);a
a<-data.frame(Murder=1,Assault=2,UrbanPop=3,Rape=4);a
rownames(a)="ac";a
sqlSave(ds,a,'USArrests',append=T)
sqlQuery(ds,"delete from USArrests where state='ac'")
odbcClose(ds)
#==========RODBC连接库=============================
library(RODBC)
ds=odbcConnect(dsn = "Supcon",uid = "robotdemo1",pwd = "supcon1304")
table=sqlTables(ds,tableType = "TABLE")
SQL=paste('select * from ','"','Comm_Contract','"',sep = '')
tt=sqlQuery(ds,SQL)
#==========RODBC本地库测试=============
library(RODBC)
ds=odbcConnect(dsn = "SQL",uid = "sa",pwd = "weilin")
#取表清单
tables=sqlTables(ds,tableType='Table')
#查询
sql_1="select * from Rdc"
sqlQuery(ds,sql_1)
#删除表
sql_2="drop table Lagou"
sqlQuery(ds,sql_2)
#创建表
sql_3="create table Lagou (ID int,Name varchar(255))"
sqlQuery(ds,sql_3)
#关闭连接
odbcClose(ds)
#==========RODBC_数据库操作示例========
library(RODBC)
conn=odbcConnect("SQL")
odbcTables(conn)
sqlTables(conn,tableType = 'TABLE')
# sqlSave(conn,dat = dat)
# sqlDrop(conn,sqtable = "dat")
sqlUpdate(conn,dat,tablename = "dat")
sqlFetch(conn,"dat")
dat=transform(dat,e=4:8)
#==========RODBC_Excel============
library(RODBC)
z = odbcConnectExcel("C:\\Documents and Settings\\zhengweilin\\My Documents\\MapApply1.xls")
fill1 = sqlFetch(z,"填色")
odbcClose(z)
#==========R数据库_RJDBC================
#DBI
# install.packages("DBI")
# install.packages("RJDBC")
library(DBI)
library(RJDBC)
# require(rJava)
if (Sys.getenv("JAVA_HOME")!="") Sys.setenv(JAVA_HOME="")
jcc = JDBC("com.ibm.db2.jcc.DB2Driver", "~/JDBC/JDBC-DB2-jar/db2jcc.jar",identifier.quote = "\"")
#连接数据库
drv = JDBC("com.ibm.db2.jcc.DB2Driver","~/JDBC/JDBC-DB2-jar/db2jcc.jar", NA)
conn46 = dbConnect(drv,"jdbc:db2://10.158.130.46:50000/hndcdb","dwinst","hndw&83d")
#抽取数据
dbListTables(conn46)
Holiday = dbReadTable(conn46, "DCDW.HOLIDAY" )
Holiday = dbGetQuery (conn46, "select * from DCDW.HOLIDAY")
head(Holiday)
#==========XML中reatHTMLTable用法==============
sessionInfo()
library(XML)
txt="http://data.eastmoney.com/stock/lhb/yyb/80357508.html"
#url= htmlParse(txt,encoding = "utf-8")
readLines(txt,encoding = "utf-8")
url=txt
tables=readHTMLTable(url)
medat<-tables$dt_1
head(medat)
str(medat)
tdat<-medat[,8]
Encoding(colnames(medat))<-"utf-8"
colnames(medat)
Encoding(tdat)<-"utf-8"
tdat
iconv
#==========RCurl爬虫：debugGatherer==================
library(RCurl)
#加载RCurl包
getKm<-function(x){
d=debugGatherer()
#设置debugGatherer，响应response
myHttpheader<-c("User-Agent"="Mozilla/5.0 (Windows NT 6.1; rv:41.0) Gecko/20100101 Firefox/41.0",
"Accept"="text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8")
#设置headers格式，followlocation＝T可以解决重定向的问题。
temp<-getURL(paste("http://zh.flightaware.com/live/flight/",x,sep=""),httpheader=myHttpheader,
debugfunction=d$update,verbose=T)
#获取网页信息
temp1<-d$value()[["headerIn"]]
url1<-regmatches(temp1,regexpr(pattern = "http:.+Vary",temp1))
url2<-unlist(strsplit(url1,"\r"))[1]
t=regmatches(url2,regexpr("\\d+{1,}$",url2))
t1=as.numeric(t)*1
url=paste(unlist(strsplit(url2,t)),t1,sep="")
#处理网页得到url地址
temp2<-getURL(url)
write(temp2,"~/tt.txt")
k=regexpr(pattern = "计划飞行距离.+km( |</td>)",temp2)
dat=regmatches(temp2,k)
#dat=regmatches(dat,regexpr("\\d.+\\d",dat))
dat
}
getKm("EY311")
getKm("EY191")
getKm("KL1763")
getKm("KL1139")
#查询指定航班所需飞行距离
#==========tm包实现分词==================
# install.packages("tm")
library(tm)
??tm
doc=c("the first text","The second text")
corpus1=Corpus(VectorSource(doc))
adress=system.file("texts","crude",package="tm")
reuters=Corpus(DirSource(adress),readerControl=list(reader=readReut21578XML))
writeCorpus(reuters)
reuters=tm_map(reuters,as.PlainTextDocument,lazy=T)
reuters
#==========分词_jiebaR=========================
#install.packages("jiebaR")
library(jiebaR)
words = "我爱北京天安门,天安门上面有很多人在看升国旗，解放军真厉害"
tagger = worker("tag")
tagged = tagger <= words
#mode(tagged)
#str(tagged)
#attr(tagged, "names")
cutter_words<-data.frame(tag = attr(tagged, "names"),value = tagged)
noun_words<-cutter_words[which(cutter_words$tag %in% c('n','nt','ns')),]
noun_words<-noun_words$value
noun_words
library(sqldf)
result<-sqldf("select * from cutter_words where tag like '%n%'")
result$value=iconv(result$value,'utf-8','gbk')
result
text = c("如果物品属于电商渠道",
"那么价格早就在网上认定了",
"可以直接按照价格赔偿","如果价值特别贵重，没有保价",
"一般来说快递公司不会按原价赔偿",
"因为贵重物品按照规定应该进行保价",
"具体赔偿金额需要双方协商")
library(jiebaR)
cc = worker("mix", bylines=T)
key = worker("keywords", topn = 4)
res = cc[text]
res_key = lapply(res, vector_keywords, key)
res_key
#==========分词_jiebaR案例1=========================
library(jiebaR)
dat=readLines("~/abc.txt",encoding = "UTF-8")
head(dat,1)
try1<-dat[1]
cc = worker("mix", bylines=T)
key = worker("keywords", topn = 10)
res = cc[dat]
res_key = lapply(res, vector_keywords, key)
head(res_key,1)
write.table(res_key,"rr.txt")
#==========wordcloud2===========
library(wordcloud)
# install.packages("wordcloud2")
library(wordcloud2)
#==========mice包====================
# install.packages("mice")
library(mice)
??mice
imp=mice(sleep,seed=1234)
fit=with(imp,lm(Dream~Span+Gest))
pooled=pool(fit)
summary(pooled)
#==========Hmisc包================
install.packages("Hmisc")
library(Hmisc)
#==========rjosn包==================
paste('{"m_crawlTime":{"$gt":"',
Sys.Date()-3,
'"},"m_newKeywords.0":{"$exists": 1},"m_Type" : {"$ne" :38}}')
# install.packages("rjson")
library(rjson)
rjson::fromJSON('
{"m_crawlTime":{"$gt":"2016-04-15"},
"m_newKeywords.0":{"$exists": 1},
"m_Type" : {"$ne" :38}}
'
)
josn='{
"m_crawlTime":{"$gt":"2016-04-15"},
"m_newKeywords.0":{"$exists": 1}",
"m_Type" : {"$ne" :38}
}'
josn
#==========分层抽样_sampling======================
# install.packages('sampling')
## 加载
library(sampling)
data("iris")
dat=iris
names(dat)=c("萼长","萼宽","瓣长","瓣宽","种类")
head(dat,3)
## 划分训练集与测试集用分层抽样函数Strata，在3类型鸢尾花数据中各抽取80%作为训练集，
## 保存在变量TrainingSet中；
## 余下的20%作为测试集，保存在变量TestSet中。过程如下所示：
nLevel=round(nrow(dat)*0.8/3,-1)
trainingSamp = strata(dat,stratanames="种类",size = rep(nLevel, 3), method="srswor")
head(trainingSamp)
#以Species变量作为分层变量
# 分层抽取训练样本，每层nPerLevel个
trainingSet = getdata(dat, trainingSamp$ID_unit)
# 训练集
testSet = getdata(dat,-trainingSamp$ID_unit)
#==========KNN、测试集、训练集===============
# install.packages("FNN")
# install.packages("rknn")
library(FNN)
library(rknn)
library(gmp)
library(fpc)
data(iris3)
head(iris3)
train <- rbind(iris3[1:25,,1], iris3[1:25,,2], iris3[1:25,,3])
test <- rbind(iris3[26:50,,1], iris3[26:50,,2], iris3[26:50,,3])
cl <- factor(c(rep("s",25), rep("c",25), rep("v",25)))
knn(train, test, cl, k = 3, prob=TRUE)
plot(knn(train, test, cl, k = 3, prob=TRUE))
#测试集、训练集划分
data(iris)
## select random train and test sets
shuffled <- iris[sample(nrow(iris)),]
n.test <- 30
train <- sample(nrow(iris), nrow(iris) - n.test)
x.train <- shuffled[train, -5]
y.train <- shuffled[train, 5]
x.test <- shuffled[-train, -5]
y.test <- shuffled[-train, 5]
#==========R和tableau集成================
# install.packages("Rserve")
library(Rserve)
Rserve()
#==========Rweibo包安装方法==================
# install.packages("Rweibo",repos = "http://R-Forge.R-project.org",type="source")
library(Rweibo)
#==========rechart安装==================
# install.packages("recharts")
library(recharts)
#==========SVM相关包========
# install.packages("e1071")
library(e1071)
svm()
#==========shiny分割线============
# install.packages("shiny")
# shiny分为ui.R和sever.R
# 其中ui.R为图形生成部分；sever.R为服务器调用部分
#==========归一化处理========
require(stats)
x <- matrix(1:10, ncol = 2)
(centered.x <- scale(x, scale = FALSE))
cov(centered.scaled.x <- scale(x)) # all 1
#原理是z-score，δ=(x-mean)/sd
#==========infotheo包：互信息========
library('infotheo')
x=c(0,1,1,1)
y=c(1,1,1,1)
mutualinformation=mutinformation(x,y)
#x向量与y向量的互信息量mutualinformation=0
#==========Github和recharts=============
library(devtools)
install_github('yihui/recharts')
#solution: there is no package called 'digest'
install.packages("digest")
library(recharts)
#==========神经网络:nnet=============
library(nnet)
??nnet
nnet()
#==========misTools=============
#misTools中的insrtRow、insertCol函数
# install.package(miscTools)
library(miscTools)
m <- matrix( 1:4, 2 )
insertRow( m, 2, 5:6 )
insertCol( m, 2, 5:6 )
#=========SparkR===========
install.packages("sparkR")
install_github("amplab-extras/SparkR-pkg", subdir="pkg")
#=========与Excel的交互========
#=========r2excel======
# library(devtools)
# devtools::install_github("kassambara/r2excel")
library(r2excel)
#=========与word交互============
#=========ReporteRs--Knitr|Rmarkdown|============
# install.packages("ReporteRs")
require(ReporteRs)
#=============tibble============
install.packages('tibble')
#==========Ending==========================
#清除变量
rm(list=ls())
5673
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
