????????筆者最近幾年家里催著結(jié)婚止后，雖然這幾年各大親網(wǎng)站紅娘、實體店、家人親戚朋友也介紹了不少妹紙渴逻，各種類型都不少猿妈，但由于筆者前面制定了一大套的標(biāo)準(zhǔn)精钮，到最后袍啡，基本能得罪的親朋好友都得罪了一遍，然后還是孤家寡人一個钾怔。碱呼。。一個偶然的原因宗侦，突然興起了利用大數(shù)據(jù)的方法探查擇偶標(biāo)準(zhǔn)是不是合理的這個想法愚臀，比如本文探索生肖沖突這件事（當(dāng)然寫下此文純粹是覺得花了些時間的事是需要簡單記錄下），我就上網(wǎng)抓了些評論凝垛，寫了個小程序做了兩個標(biāo)簽（一個是實例和觀點，一個是正面評價和負(fù)面評價）的分類（這里僅以雞犬相害作為例子拋磚引玉蜓谋，有興趣的同學(xué)可以拿我后面的程序去修改去找你感興趣的問題）梦皮，然后得出的結(jié)論大概是這樣子的：
1、我們看到觀點上桃焕，只有23%不到的人認(rèn)為雞犬沒有沖突剑肯，而實例上是，68%的存在雞犬生肖搭配的夫妻或情侶認(rèn)為他們關(guān)系不錯或還過得去观堂，只有32%的人發(fā)現(xiàn)這種感情關(guān)系是不好或失敗的 让网，為什么會出現(xiàn)這種情況，我覺得根據(jù)熵原理來說师痕，具體的溃睹、有點聊頭的觀點信息量會比較大，也有利于傳播和交流胰坟，所以容易形成夸大的偏見
2笔横、之所以親子關(guān)系相對來說更容易不和的趕腳竞滓，發(fā)現(xiàn)這里親子關(guān)系大都是和她媽媽，而估計這里留言的大多是女生吹缔，母女之間觀念差異肯定會帶來一些感受上的不好商佑，這種不好往往會表達(dá)出來，但并不代表親子關(guān)系不好?
3肌幽、從這個數(shù)據(jù)我們只能知道屬雞和屬狗的夫妻或情侶有70%左右的可以相處和諧，但并不能證明屬雞和屬狗生肖相處不具有負(fù)面或正面效應(yīng)礁叔，畢竟沒有評估其他生肖關(guān)系作為參考牍颈，但僅以這些樣本的統(tǒng)計結(jié)果來看，我大概瞄了一眼琅关，分類為不和的里面最多有一半提及分手或離婚了煮岁，也就是這里的離婚率應(yīng)該低于20%，大家可以對比下我國近10年離婚率均值參考下
?4涣易、這個數(shù)據(jù)來源為豆瓣画机、知乎評論，有可能存在樣本分布范圍有偏頗的情況
?5新症、最后根據(jù)這個數(shù)據(jù)步氏，我得出結(jié)論是影響婚姻愛情和諧的因素有很多，雖然觀念或觀點會帶來一些偏見或負(fù)面影響徒爹，但我們看到荚醒，在這種偏見影響下，屬雞屬狗的兩人仍然大部分能夠很嗨皮的享受兩人時光
ok隆嗅，結(jié)論擺完了界阁，以下為實現(xiàn)步驟（有點專業(yè)，非程序猿建議忽略）：
1胖喳、從百度搜了幾篇豆瓣和知乎的這方面討論帖子泡躯，然后寫個小爬蟲抓取下來
2、然后對抓取下來的大約500來條評論進(jìn)行去重和標(biāo)注丽焊，大約標(biāo)注了100條數(shù)據(jù)较剃，標(biāo)注分為3個標(biāo)簽，其中一個標(biāo)簽分類事實還是觀點技健，一個標(biāo)簽分類親子關(guān)系還是夫妻關(guān)系写穴，一個標(biāo)簽分類對這種關(guān)系的情感態(tài)度
3、然后執(zhí)行文本清洗和分詞雌贱，最后做了3個分類任務(wù)确垫，分別用最大熵、隨機(jī)森林帽芽、一些boost和stack的方法做了一下測試删掀，由于寫這篇文章離做完得出結(jié)果有段時間了，我也不記得哪個方法在哪個任務(wù)上的性能比較好了导街，大家可以自己去嘗試披泪。
4、由于幾個標(biāo)簽任務(wù)的分類結(jié)果都還算不錯搬瑰，所以沒做太多的算法優(yōu)化款票，最后幾種分類模型的結(jié)果出現(xiàn)不一致的時候采用簡單的加權(quán)（測試集上的準(zhǔn)確率作為權(quán)重）投票的方式得出最后的分類結(jié)果
以下為部分代碼：
scrapy.py
import urllib.request
import requests
import urllib.parse
import reimport urllib.request, urllib.parse, http.cookiejar
from bs4import BeautifulSoup
# urls存儲url控硼，new_urls存儲待爬取的url，old_urls存儲已經(jīng)爬過的url
class UrlManger(object):
"""docstring for UrlManger"""
? ? def __init__(self):
self.new_urls =set()# 定義new_urls為一個集合,用來存儲還未parse的urls
? ? ?self.old_urls =set()
? ? def get_new_url(self):
new_url =self.new_urls.pop()
? # print('get_new_urllalalala'+ new_url)
? ? ? ? self.old_urls.add(new_url)
return new_url
#添加urls到集合
? ? def add_new_urls(self, urls):
if urlsis None or len(urls) ==0:
r#添加urls到集合eturn
? ? ? ? else:
for urlin urls:
self.add_new_url(url)
# 添加url的規(guī)則
? ? def add_new_url(self, url):
if urlis None:
return
? ? ? ? if urlnot in self.new_urlsand urlnot in self.old_urls:
self.new_urls.add(url)
# 判斷是否還有url
def has_new_url(self):
return (len(self.new_urls)) !=0
#? htmldownloader函數(shù)：用于頁面的下載
class HtmlDowloader(object):
"""docstring for UrlManger"""
? ? def __init__(self):
pass
? ? #使用request來請求獲取相關(guān)頁面完成頁面的下載
? ? def download(self, url):
if urlis None:
return None
? ? ? ? headers = {
'user-agent':'Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/38.0.2125.122 Safari/537.36 SE 2.X MetaSr 1.0'}
response = requests.get(url, headers=headers)
? ? ? ? if response.status_code !=200:
print(response.status_code)
? ? ? ? ? ? return None
? ? ? ? return response.content
class HtmlParser(object):
"""docstring for HtmlParser"""
? ? def __init__(self):
pass
#使用soup來完成頁面連接的獲取艾少，并將發(fā)現(xiàn)的url添加到new_urls中卡乾，返回new_urls
? ? def _get_new_urls(self, page_url, soup):
new_urls =set()
?links_discuss = soup.find_all('a', href=re.compile(r"/discussion"))# 審查元素，表示頁面的鏈接含有discussion
? ? ? ? links_topic = soup.find_all('a', href=re.compile(r"/topic/\d+"), text=re.compile(u'屬雞'))?
? ? ? ? for link1in links_topic:
print(link1.get_text())# 打印標(biāo)題
? ? ? ? links = links_discuss
? ? ? ? for linkin links:
? ? ? ? ? ? new_url = link['href']
? ? ? ? ? ? new_full_url = urllib.parse.urljoin(page_url, new_url)# urljoin的作用是把前一個鏈接和后面的鏈接合并成一個完整的鏈接
? ? ? ? ? ? # print(page_url)
? ? ? ? ? ? new_urls.add(new_full_url)
return new_urls
def _get_new_data(self, page_url, soup):
res_data = {}
?people_node = soup.find('a', href=re.compile(r"/people/\d+"))
print(people_node)
?res_data['people']=people_node.get_text()
? ? ? ? return res_data
def parse(self, page_url, html_cont):
if page_urlis None or html_contis None:
return
?soup = BeautifulSoup(html_cont, "html.parser", from_encoding='utf-8')
new_urls =self._get_new_urls(page_url, soup)
new_data =self._get_new_data(page_url, soup)
return new_urls, new_data
class HtmlOutputer(object):
"""docstring for HtmlOutputer"""
? ? def __init__(self):
pass
? ? def output(self):
print('craw successfully')
def collect_data(new_data):
print('get new data successfully')
class SpiderMain(object):
"""docstring for SpiderMain"""
? ? def __init__(self):
? ? ? ? print('SpiderMain begin')
self.urls = UrlManger()
? ? ? ? self.downloader = HtmlDowloader()
self.parser = HtmlParser()
self.outputer = HtmlOutputer()
def craw(self, root_url):
count =1
? ? ? ? self.urls.add_new_url(root_url)
while self.urls.has_new_url():
try:
new_url =self.urls.get_new_url()
print('craw %d:%s' % (count, new_url))
html_cont =self.downloader.download(new_url)
new_urls, new_data =self.parser.parse(new_url, html_cont)
self.urls.add_new_urls(new_urls)
? ? ? ? ?if count ==3:
break
? ? ? ? ? ? ? ? count = count +1
? ? ? ? ? ? except:
print(count, 'craw failed')
self.outputer.output()
if __name__ =='__main__':
root_url ='https://www.douban.com/group/148995/'
? ? obj_spider = SpiderMain()
obj_spider.craw(root_url)
Main.py
import urllib.request
from bs4import BeautifulSoup
def getHtml(url):
"""獲取url頁面"""
? ? headers = {'User-Agent':'Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/62.0.3202.94 Safari/537.36'}
req = urllib.request.Request(url,headers=headers)
req = urllib.request.urlopen(req)
content = req.read().decode('utf-8')
return content
def getComment(url):
"""解析HTML頁面"""
? ? html = getHtml(url)
soupComment = BeautifulSoup(html, 'html.parser')
comments = soupComment.findAll('p', '')
onePageComments = []
for commentin comments:
onePageComments.append(comment.getText()+'\n')
return onePageComments
if __name__ =='__main__':
urlSets =set()
urlSets.add('https://www.douban.com/group/topic/110824994/')
urlSets.add('https://www.douban.com/group/topic/105044195/')
urlSets.add('https://www.douban.com/group/topic/72264943/')
urlSets.add('https://www.douban.com/group/topic/82920501/')
urlSets.add('https://www.douban.com/group/topic/57243174/')
for urlbeforein urlSets:
filename ='雞狗相害page' +str(i) +'.txt'
? ? ? ? ? ? i +=1
? ? ? ? ? ? f =open(filename, 'w', encoding='utf-8')
for pagein range(5):# 豆瓣爬取多頁評論需要驗證缚够。
? ? ? ? ? ? ? ? url = urlbefore+str(100*page)
print('第%s頁的評論:' % (page+1))
print(url +'\n')
for iin getComment(url):
f.write(i)
print(i)
print('\n')
docUtil.R
library(rJava)
library(Rwordseg)
library(tm)
library(maxent)
###########################清洗文本############################################################
docClean<-function(sentence){
? sentence <- gsub(pattern = " ", replacement ="", sentence) ?? ? sentence <- gsub("\t", "", sentence)?
?sentence <- gsub(",", "幔妨，", sentence)??
sentence <- gsub("~|'", "", sentence)
? sentence <- gsub("\\\"", "", sentence)
? return(sentence)
}
##############################數(shù)據(jù)清洗特殊字符################################################
docCleanSp<-function(sentence){
? juzi <- as.vector(sentence) #文本內(nèi)容轉(zhuǎn)化為向量sentence
? juzi <- gsub("[[:digit:]]*", "", juzi) #清除數(shù)字[a-zA-Z]
? juzi <- gsub("[a-zA-Z]", "", juzi)? #清除英文字符
? juzi <- gsub("\\.", "", juzi)? ? ? #清除全英文的dot符號
? juzi <- juzi[!is.na(juzi)]? #清除對應(yīng)sentence里面的空值（文本內(nèi)容），要先執(zhí)行文本名
? juzi <- juzi[!nchar(juzi) < 2] #`nchar`函數(shù)對字符計數(shù)谍椅，英文嘆號為R語言里的“非”函數(shù)
? return(juzi)
}
#########################構(gòu)造評論包含的詞對應(yīng)的相應(yīng)的列（類別標(biāo)簽误堡，觀點標(biāo)簽)，并最后整合到一起
doc2termVec<-function(juzi){
? system.time(x <- segmentCN(strwords = juzi))
? temp <- lapply(x, length) #每一個元素的長度,即文本分出多少個詞
? temp <- unlist(temp)? #lapply返回的是一個list雏吭，所以3行unlist
? id <- rep(df[, "id"], temp) #將每一個對應(yīng)的id復(fù)制相應(yīng)的次數(shù)锁施，就可以和詞匯對應(yīng)了
? class <- rep(df[, "class"], temp)#id對應(yīng)的情感傾向標(biāo)簽復(fù)制相同的次數(shù)
? term <- unlist(x) #6行將list解散為向量
? view<-rep(df[, "view"], temp)
? testterm <- as.data.frame(cbind(id, term, class,view), stringsAsFactors = F)
? return(testterm)
}
##################################執(zhí)行停用詞處理的函數(shù)##################################
removeStopWords<-function(x,words){
? ret<-character(0)
? index<-1
? it_max<-length(x)
? while(index<=it_max){
? ? if(length(words[words==x[index]])<1)ret<-c(ret,x[index])
? ? index<-index+1
? }
? ret
}
MdlBuild.R
###加載必須的包體和載入相關(guān)環(huán)境變量
library(rpart)
library(e1071)
library(sjmisc)
library(ROSE)
library(ROCR)
library(DMwR)
library(maxent)
#########模型評選AUC
calcAuc2<-function(predcol,outcol){
? ? ? perf<-performance(prediction(predcol,outcol==1),'auc')
? ? ? as.numeric(perf@y.values)
}
#####################常用建模函數(shù)###############
###貝葉斯分類
bayesMdl<-function(predcol,trainset,testset){
? ? ? precol=colnames(predcol)
? ? ? print(table(predcol[,precol]))
? ? ? print(table(testset[,precol]))
? ? ? mdl <- naiveBayes(trainset[,precol]~., data = trainset)
? ? ? pred <- predict(mdl, newdata = testset)
? ? ? print(table(pred,testset[,precol]))
? ? ? print(cbind(pred,testset[,precol]))
? ? ? print(testset[,precol])
? ? ? print(roc.curve(testset[,precol], pred, plotit = F))
? ? ? #return(pred)
}
###########################下面面使用決策樹來建模##########################
dtMdl<-function(predcol,trainset,testset){
? ? ? precol=colnames(predcol)
? ? ? print(table(trainset[,precol]))
? ? ? print(table(testset[,precol]))
? ? ? treeimb <- rpart(trainset[,precol] ~ ., data = trainset)
? ? ? pred <- predict(treeimb, newdata = testset)
? ?? ?level<-as.vector(colnames(pred))
? ? ? dfPred<-as.data.frame(pred)
? ? ? dfPred$class<-ifelse(pred[,1]>0.5,level[1],ifelse(pred[,2]>0.5,level[2],level[3]))
? ? ? dfPred$pre<-ifelse(testset[,precol]==dfPred$class,1,0)
? ? ? test<-cbind(testset[,precol],dfPred)
? ? ? print(paste("there is ratio :", sum(dfPred$pre)/nrow(dfPred)))
? return(pred)
}
#####最大熵建模函數(shù)，計算用于最大熵的訓(xùn)練時間
maxentMdl<-function(precol,trainset,testset){
? ptm <- proc.time()
? colnum<-dim(trainset)[2]
? model <- maxent(trainset[,2:colnum],precol)?
? ptms <- proc.time() - ptm
? print(ptms)
? m <- testSet[,2:colnum]
? n <- testSet[,1]
? #計算最大熵模型用于測試的時間
? ptm <- proc.time()
? ms <- predict.maxent(model,m)? #測試
? ptms <- proc.time() - ptm
? print(ptms)
? #計算準(zhǔn)確率
? kn <- as.character(n) #類別數(shù)組
? km <- ms[,1]? ? ? ? ? #預(yù)測后的類別數(shù)組
? print(table(km))
? calculate_mean <- function(kn,km)
? {
? ? num <- 0
? ? for(i in 1:length(kn))
? ? {
? ? ? if(kn[i]==km[i])
? ? ? {
? ? ? ? num <- num + 1
? ? ? }
? ? }
? ? return (num/length(kn))
? }
? print(calculate_mean(kn,km))
? return(km)
}?
###################################使用隨機(jī)森林建模##################################
rfMdl<-function(predcol,trainset,testset){
? ? library(randomForest)
? ? set.seed(5123512)
? ? precol=colnames(predcol)
? ? tmdl<-randomForest(x=trainset,y=trainset[,precol],ntree=50,importance=T)
? ? pred <-predict(tmdl,newdata = testset)
? ? print(head(pred,25))
? ? print(head(testset[,precol],25))
? ? print(table(pred))
? ? dfPred<-as.data.frame(pred)
? ? dfPred$pre<-ifelse(testset[,precol]==pred,1,0)
? ? print(paste("there is ratio :", sum(dfPred$pre)/nrow(dfPred)))
? ? return(pred)
}
##高斯混合模型EM算法#####
###加載必須的包體和載入相關(guān)環(huán)境變量
Sys.setenv(JAVA_HOME="c:/Program Files/Java/jre1.8.0_201/")
setwd("E:/R_workspace/rdmdata/")
library(rJava)
library(xlsx)
library(mclust)
require(mclust)
bodys<-read.csv("bodys_em.csv",header=T,sep=',')
mean0<-170
mean1<-170
std0<-3
std1<-3
xVec<-bodys$height
##################以下函數(shù)試圖求出M-step的參數(shù)值值#########
estep_two<-function(x,a0,mean0,mean1,std0,std1){
? m0<-(x-mean0)^2/(2*std0^2)
? m1<-(x-mean1)^2/(2*std0^2)
? w_est0<-1/sqrt(std0)*exp(-m0)*a0
? print(paste("w_est0 is : ",w_est0))
? w_est1<-1/sqrt(std1)*exp(-m1)*(1-a0)
? print(paste("w_est1 is : ",w_est1))
? w_est<-w_est0/(w_est0+w_est1)
? print(paste("w_est is : ",w_est))
? return(w_est)
}
em_gaussian_two<-function(xVec,mean0,mean1,std0,std1,threshold,iters){
? ###########################初始化相關(guān)參數(shù)####################
? w0<-0.5
? wVec<-sapply(xVec,function(x,w=w0,miu0=mean0,miu1=mean1,st0=std0,st1=std1)estep_two(x,w,miu0,miu1,st0,st1))
? m_est<-mean(wVec)
? iter=1
? ##########################E—M-step迭代#####################
? while(iter<iters){
? ? ? ? W<-sum(wVec)/length(wVec)
? ? ? ? mean0_new<-(wVec %*% xVec)/sum(wVec)
? ? ? ? print(paste("mean0_new is :",mean0_new))
? ? ? ? dValue<-xVec-as.vector(mean0_new)
? ? ? ? std0_new<-sqrt(sum(dValue^2)/length(wVec))
? ? ? ? mean1_new<-((1-wVec)%*% xVec)/sum(1-wVec)
? ? ? ? print(paste("mean1_new is :",mean1_new))
? ? ? ? std1_new<-sqrt(sum((xVec-as.vector(mean1_new))^2)/length(wVec))
? ? ? ? wVec<-sapply(xVec,function(x,w=W,miu0=mean0_new,miu1=mean1_new,st0=std0_new,st1=std1_new)
? ? ? ? estep_two(x,w,miu0,miu1,st0,st1))
? ? ? ? delta<-abs(sum(wVec)/length(wVec)-W)
? ? ? ? print(paste("delta is :",delta))
? ? ? ? if(delta<threshold){
? ? ? ? ? print(paste("delta is below threshold:",delta))
? ? ? ? ? break
? ? ? ? }
? ? ? ? iter<-iter+1
? ? ? ? print(paste("iter is :",iter))
? }
? return(c(std1=std0_new,mean1=mean0_new,std2=std1_new,mean2=mean1_new))
}
######當(dāng)我們認(rèn)為有m個高斯混合模型時杖们，如何計算出expectation
estep<-function(X,W,AVG,STD){##W為隱含變量向量悉抵，即假設(shè)的多個高斯模型的隱含概率分布
? k=0
? len<-length(W)
? m<-vector(length = len)
? w_est<-vector(length = len)
? while(k<length(len)){
? ? ? m[k]<-(x-AVG[k])^2/(2*STD[k]^2)
? ? ? w_est[k]<-1/sqrt(STD[k])*exp(-m[k])*W[k]##這里w_est[k]為對第k個w的估計
? }
? return(w_est) #這里返回對w的估計向量
}
#logistic來分類
glmMdl<-function(predcol,trainset,testset){
? ? ? precol=colnames(predcol)
? ? ? print(table(predcol[,precol]))
? ? ? print(table(testset[,precol]))
? ?? ?mdl <- glm(formula=trainset[,precol]~., data = trainset)
? ? ? modelGlm2<-step(mdl,trace=0)
? ? ? summary(modelGlm2)
? ? ? #模型顯著性檢驗
? ? ? anova(object=modelGlm2,test="Chisq")
? ? ? HL_test <- hoslem_gof(x = modelGlm2)
? ? ? pred<- predict(modelGlm2, newdata = testSet)
? ? ? accuracy.meas(as.numeric(testset[,precol]), as.numeric(pred>0.5))
}
logLikelyhood<-function(outcol,predcol){
? ? sum(ifelse(outcol==pos,log(predcol),log(1-predcol)))
}? ??
##########################使用bagging來建模############################
ntrain<-dim(dTrain)[1]
n<-ntrain
ntree<-100
fv<-paste(outcome,'==1 ~ ',paste(selVars,collapse = ' + '),sep='')
#####獲取取樣函數(shù)。執(zhí)行ntree次迭代摘完，每次迭代獲取取樣序號姥饰，最后形成ntree個取樣序列
samples<-sapply(1:ntree, FUN=function(iter){
? sample(1:ntrain,size = n,replace = T)
})
treelist<-lapply(1:ntree, FUN = function(iter){
? samp<-samples[,iter];
?rpart(fv,data=dTrain[samp,],control=rpart.control(cp=0.001,minsplit=1000,minbucket=1000,maxdepth=5))
})
predict.bag<-function(treelist,newdata){
? preds<-sapply(1:length(treelist),FUN = function(iter){
? ? predict(treelist[[iter]],newdata=newdata)
? })
? predsums<-rowSums(preds)
? predsums/length(treelist)
}
accuracyMeasures <- function(pred, truth, name="model") {
? dev.norm <- -2*loglikelihood(as.numeric(truth), pred)/length(pred) ?
? ctable <- table(truth=truth,
? ? ? ? ? ? ? ? ? pred=(pred>0.5)) ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ??
? accuracy <- sum(diag(ctable))/sum(ctable)
? precision <- ctable[2,2]/sum(ctable[,2])
? recall <- ctable[2,2]/sum(ctable[2,])
? f1 <- precision*recall
? data.frame(model=name, accuracy=accuracy, f1=f1, dev.norm)
}
knnPred <- function(nK,df) {?
? knnDecision <- knn(knnTrain,df[,selVars],knnCl,k=nK,prob=T)
? pred<-ifelse(knnDecision==TRUE,?
? ? ? ? attributes(knnDecision)$prob,
? ? ? ? 1-(attributes(knnDecision)$prob))
? print(paste(calcAUC(pred,df[,outcome]),' nk is : ',nK) )
}
dataStats.R
library(Hmisc)
library(DMwR)
mystats<-function(x,na.omit=F){
??? ???if(na.omit)
? ?? ???x<-x[!is.na(x)]
??? ???m<-mean(x)
??? ???n<-length(x)
??? ???s<-sd(x)
??? ???skew<-sum((x-m)^3/s^3)/n
?? ???kurt<-sum((x-m)^4/s^4)/n-3
?? ???return(c(n=n,mean=m,stdev=s,skew=skew,kurt=kurt))
}
mySimpleSummary<-function(x,na.omit=F){
??? ??colName<-colnames(x)
??? ??hist(x[,colName],prob = T,xlab=colName,main=paste("Hist of ",colName))
??? ??lines(density(x[,colName],na.rm = T))
?? ???rug(jitter(x[,colName])) #x軸數(shù)據(jù)分布密集性，jitter為對原始值隨機(jī)排列的函數(shù)
}
#對數(shù)據(jù)框中的某列進(jìn)行描述性統(tǒng)計
mySummary<-function(x,na.omit=F){
? ? ? ? ? print(summary(x))
? ? ??? ??colName<-colnames(x)
? ? ?? ???par(mfrow=c(2,2))
? ? ?? ???hist(x[,colName],prob = T,xlab=colName,main=paste("Hist of ",colName))
? ? ?? ???lines(density(x[,colName],na.rm = T))
? ? ?? ???rug(jitter(x[,colName])) #x軸數(shù)據(jù)分布密集性描焰，jitter為對原始值隨機(jī)排列的函數(shù)
? ? ?? ???qqPlot(x[,colName],xlab=colName,main=paste("qq plot of ",colName))
? ? ??? ?
? ? #對數(shù)據(jù)簡單清洗,對缺失值用均值填充
? ? ? ? ?x[which(is.na(x)),]<-mean(x[,1], na.rm = T)
? ? #數(shù)據(jù)分布箱圖
? ? ??? ??boxplot(x[,colName],ylab=paste("distribution of",colName),col="gold")
? ? ?? ???title(paste("box plot of ",colName))
? ? ?? ???rug(jitter(x[,colName]),side=2) #y軸數(shù)據(jù)分布密集性
? ? ??? ??abline(h=mean(x[,colName],na.rm = T),lty=1)
? ? ?? ???abline(h=mean(x[,colName],na.rm = T)+sd(x[,colName],na.rm = T),lty=2)
? ? ??? ??abline(h=median(x[,colName],na.rm = T),lty=3)
? ? #數(shù)據(jù)分布提琴圖
? ? ??? ??vioplot(x[,colName],names=colName,col="blue")
? ? ?? ???title(paste("viobox plot of ",colName))
? ? ??? ??rug(jitter(x[,colName]),side=2) #y軸數(shù)據(jù)分布密集性
? ? ?? ???abline(h=mean(x[,colName],na.rm = T),lty=1)
}
#繪制條件分位箱圖
myBwplot<-function(x){
??? ??bwplot( size~a1, data=test_data, panel=panel.bpplot,
? ? ? ? ? probs=seq(.01,.49,by=.01), datadensity = TRUE,
? ? ? ? ? ylab=paste('river ',size), xlab=paste('Algal ',a1)
? ? ? ? )
}
?calcAuc<-function(predcol,outcol){
??? ??? ??? ? ? ??? ??perf<-performance(prediction(predcol,outcol==pos),'auc')
??? ??? ? ? ??? ??? ??as.numeric(perf@y.values)
? ??}
#查找數(shù)據(jù)框中的na個數(shù)滿足一定條件的行并顯示出來
naDataView<-function(x){
? ? m<-floor(length(x)/5)
? ? b<-rowSums(is.na(x))>=m
? ? return (x[b,])
}
#查找變量na個數(shù)并反回百分比
naColpercent<-function(x){
? ? a<-colSums(is.na(x))
? ? per<-a/nrow(x)
? ? return(per)
}
##相關(guān)性矩陣簡化顯示
symnum(cor(df_clean,use='complete.obs'))
#對數(shù)據(jù)框中那些缺失值較多的樣本進(jìn)行刪除媳否，對其它樣本進(jìn)行填充操作
dataClean<-function(x,y,df){
??? ??factorCount<-table(x$y)? #計算每個類別的樣本數(shù)
??? ??naFaCount<-table (naDataView(x$y))? #計算每個類別含有na且滿足刪除條件的樣本數(shù)
??? ??naPercent<-naFaCount/factorCount? ? #計算可刪除樣本在每個類別中比例
??? ??c<-sapply(naPercent, function(x) x=0.05)
??? ??cna = c/naPercent
?? ???if(sum(cna>1)==length(naPercent)){ ?
? ? x<-na.omit(x)
? }else{
? ? dataReplace(df)
? }
? return(x)
}
#對有缺失值的變量根據(jù)相關(guān)關(guān)系進(jìn)行填充
fillCorNa1=function(x) sapply(x[is.na(x),1],function(x)
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? if(is.na(x))
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? return (NA)
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? else
? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? return (lineCor[1]+lineCor[2]*x)
? ? ? ? ? ? ? ? ? )
#對缺失值根據(jù)相關(guān)關(guān)系進(jìn)行計算
fillCorNa2<-function(x,lineCor){
? if(is.na(x))
? ? return (NA)
? else {
? ? return (lineCor[1]+lineCor[2]*x)
? }
}
#簡單替換缺失值
simpleDfClean<-function(df,x){
? df<-df[-manyNAs(x),0.1]
? df<-knnImputation(df,k=10)
? return (df)
}
#獲取兩個向量的線性關(guān)系并返回相應(yīng)線性函數(shù)
getlineCor<-function(x,y){
? ? lm1<-lm(y~x)
? ? cof<-c(lm1$coefficients[1],lm1$coefficients[2])
? ? return(cof)
}
test.R
library(rJava)
library(xlsx)
library(Rwordseg)
library(tm)
###讀取文本栅螟，生成各種向量
test<-read.xlsx2("生肖匹配分析.xlsx",1,header=T,fileEncoding = "UTF-8")
class<-read.csv("class.csv",header = T)
view<-read.csv("view.csv",header = T)
df<-cbind(class,view,test)
id<-seq(1,454,by=1)
df<-cbind(id,df)
#head(df,10)
###對文本內(nèi)容進(jìn)行清洗
df$sentence<-doc_clean(df$sentence)
sentence<-unique(df$sentence)
#####################對所有文檔執(zhí)行停用詞處理,并生成文檔list##################################
data_stw <- readLines("chineseStopWords.txt",encoding? = "UTF-8")
########################################生成文檔list########################################
doc_CN <- list()
? for(j in 1:dim(df)[1])
? {
? ? x <- c(segmentCN(as.character(df[j,4])),nosymbol=TRUE) #對文檔分詞
? ? doc_CN[[j]] <- removeStopWords(x,data_stw)? ? #去停用詞
? }
########################################構(gòu)建語料庫###############################################
kvid <- Corpus(VectorSource(doc_CN)) #調(diào)用tm包中的函數(shù)荆秦，生成語料庫格式文檔。
meta(kvid,"class") <- class
#unique_class <- unique(class)
kvid <- tm_map(kvid,stripWhitespace)#去除文檔中因去停用詞導(dǎo)致的空白詞力图。
########################生成詞項-文檔矩陣(TDM)步绸，注意這里只包含文檔中句子成分####################
control=list(removePunctuation=T,minDocFreq=1,wordLengths = c(1, Inf))
tdm=TermDocumentMatrix(kvid,control)#詞項-文檔矩陣
ts.tdm<-DocumentTermMatrix(kvid,control)
sample.dtm <- TermDocumentMatrix(kvid, control = list(wordLengths = c(2, Inf)))
tdm_removed3=removeSparseTerms(ts.tdm,0.99)
tdm_matrix4 <- as.matrix(tdm_removed3)
#默認(rèn)的加權(quán)方式是TF-IDF,removePunctution，去除標(biāo)點吃媒，
#minDocFreq = 1表示至少詞項至少出現(xiàn)了1次瓤介，wordLengths則表示詞的長度。
#讀取類別和其對應(yīng)的數(shù)量赘那。為的是在詞項文檔矩陣后加入類別刑桑，便于后來的分類。
##typ_text = read.table("部門類別及數(shù)量.txt",sep='\t',header = TRUE,row.names=1,fileEncoding = "UTF-8")
n=1
######################################################################
? for(i in 1:3){
? ? m=n+table(class)[[i]]
? ? #ts <- inspect(tdm[1:length(tdm$dimnames$Terms),n:m-1])? ###這里是生成某個類別的m-n-1個文本(行)-詞(列)矩陣向量
? ? ?colnum<-ncol(tdm_matrix4)
? ? tk<-tdm_matrix4[n:m-1,4:colnum]
? ? tf<-as.matrix(class[n:m-1,])
? ? colnames(tf)<-"class"
? ? tm<-cbind(tf,tk)? #####將文檔-詞項矩陣中的文檔所對應(yīng)的類別綁定起來
? ? filename <- paste(i,'.txt',sep = "")? ##然后寫入到類別所在的表格文件里
? ? write.table(tm,filename,sep = "\t", col.names = NA,fileEncoding = "UTF-8")
? ? n=n+table(class)[[i]]
? }
###########################以下為文本分類代碼######################?
? library(tm)
? trainSet <- data.frame(NULL)
? testSet <- data.frame(NULL)
? #循環(huán)測試
? ? filename <- paste(1,'.txt',sep="")
? ? text = read.table(filename, header = TRUE, sep = "\t", row.names=1,fileEncoding = "UTF-8")
? ? len <- dim(text)[1]
? ? colnum<-dim(text)[2]
? ? sam <- trunc(len * 1 / 2) #取文檔2/3的數(shù)據(jù)募舟。trunc函數(shù)用于取整
? ? trainSet <- rbind(trainSet,text[1:sam,]) #將2/3的數(shù)據(jù)放置于訓(xùn)練集
? ? k <- sam + 1
? ? testSet <- rbind(testSet,text[k:len,]) #剩余的數(shù)據(jù)放置于測試集
? ? filename <- paste(3,'.txt',sep="")
? ? text = read.table(filename, header = TRUE, sep = "\t", row.names=1,fileEncoding = "UTF-8")
? ? sam <- trunc(len * 1 / 2)?
? ? trainSet <- rbind(trainSet,text[1:sam,]) #將2/3的數(shù)據(jù)放置于訓(xùn)練集
? ? k <- sam + 1
? ? testSet <- rbind(testSet,text[k:len,]) #剩余的數(shù)據(jù)放置于測試集
? ########################構(gòu)建訓(xùn)練集###########################
? ? filename <- paste(1,'.txt',sep="")
? ? text = read.table(filename, header = TRUE, sep = "\t", row.names=1,fileEncoding = "UTF-8")
? ? len <- dim(text)[1]
? ? colnum<-dim(text)[2]
? ? trainSet <- rbind(trainSet,text)
? ? filename <- paste(3,'.txt',sep="")
? ? text = read.table(filename, header = TRUE, sep = "\t", row.names=1,fileEncoding = "UTF-8")
? ? trainSet <- rbind(trainSet,text) #將2/3的數(shù)據(jù)放置于訓(xùn)練集
? ? filename <- paste(2,'.txt',sep="")
? ? text = read.table(filename, header = TRUE, sep = "\t", row.names=1,fileEncoding = "UTF-8")
? ? testSet <- rbind(testSet,text) #剩余的數(shù)據(jù)放置于測試集
? ################構(gòu)建完整數(shù)據(jù)集###########################
? sets<-data.frame(NULL)
? for(i in 1:3){
? ? filename <- paste(i,'.txt',sep="")
? ? text = read.table(filename, header = TRUE, sep = "\t", row.names=1,fileEncoding = "UTF-8")
? ? sets <- rbind(sets,text)
? }
? ##############構(gòu)建包含view祠斧、class、sentence拱礁、分詞結(jié)果的完整矩陣##############################
? filename <- paste('result2','.txt',sep = "")?
? testSet = read.table(filename, header = TRUE, sep = "\t", row.names=1,fileEncoding = "UTF-8")
? id<-row.names(testSet)
? sets[id,"class"]<-testSet[id,"pred"]
? sets<-sets[which(row.names(sets)!="701"),]
? sets<-sets[which(row.names(sets)!="3801"),]
? sentence<-as.data.frame(df$sentence)
? setence<-sentence[,1]
? view<-read.csv("view.csv",header = T)
? result<-cbind(view,sets[,"class"],setence,sets)
? filename <- paste('result1','.txt',sep = "")? ##然后寫入到類別所在的表格文件里
? write.table(result,filename,sep = "\t", col.names = NA,fileEncoding = "UTF-8")
? factsSet<-result[which(result$class=='facts'),]
? viewSet<-result[which(result$class=='view'),]
? trainSet <- data.frame(NULL)
? testSet <- data.frame(NULL)
? colnum<-dim(result)[2]
? resultSet<-result[which(result$view!='unkown'),c(1,5:colnum)]
? testSet<-result[which(result$view=='unkown'),c(1,5:colnum)]
? len <- dim(resultSet)[1]
? colnum<-dim(resultSet)[2]
? #############################構(gòu)建訓(xùn)練測試集琢锋，用來進(jìn)行模型選擇##################
? sam<-sample.int(len,len/3,replace = FALSE)
? #sam <- trunc(len * 1 / 2) #取文檔2/3的數(shù)據(jù)辕漂。trunc函數(shù)用于取整
? trainSet<-rbind(trainSet,resultSet[sam,])
? testSet<-rbind(testSet,resultSet[-sam,])
? trainSet$view<-factor(trainSet$view,levels=c("mid","neg","pos"))
? testSet$view<-factor(testSet$view,levels=c("mid","neg","pos"))
? #############################構(gòu)建真正訓(xùn)練測試集，用來進(jìn)行建模及分類##################
? trainSet <- data.frame(NULL)
? trainSet <- resultSet
? len<-dim(testSet)[1]
? trainSet$view<-factor(trainSet$view,levels=c("mid","neg","pos"))
? testSet[1:10,1]<-"mid"
? testSet[11:20,1]<-"neg"
? testSet[21:len,1]<-"pos"
? testSet$view<-factor(testSet$view,levels=c("mid","neg","pos"))
? dtMdl(trainSet[1],trainSet,testSet)
? rfPre<-rfMdl(trainSet[1],trainSet,testSet)
? mxPre<-maxentMdl(trainSet$view,trainSet,testSet)
? id<-row.names(testSet)
? sentence<-as.data.frame(df$sentence)
? test_sentence<-sentence[id,1]
? test<-cbind(rfPre,mxPre,test_sentence,testSet)
? id2<-row.names(trainSet)
? class<-result[which(result$view=='unkown'),2]
? test<-cbind(class,rfPre,mxPre,test_sentence,testSet)
? test_sentence<-sentence[id2,1]
? rfPre<-trainSet$view
? mxPre<-trainSet$view
? class<-result[which(result$view!='unkown'),2]
? train<-cbind(class,rfPre,mxPre,test_sentence,trainSet)
? result2<-rbind(test,train)
? filename <- paste('result211','.txt',sep = "")? ##然后寫入到類別所在的表格文件里
? write.table(result2,filename,sep = "\t", col.names = NA,fileEncoding = "UTF-8")
####貌似簡書不能上傳文件吴超，只好作罷钉嘹，大家自己去抓豆瓣評論吧，作者手里也有結(jié)果數(shù)據(jù)集鲸阻，有興趣的同學(xué)可以找我要
