【机器学习与R语言】3-概率学习朴素贝叶斯（NB）

2023-08-06 16:12:46

1.理解朴素贝叶斯
- 1）基本概念
- 2）朴素贝叶斯算法
2.朴素贝斯分类应用

1.理解朴素贝叶斯

1）基本概念

依据概率原则进行分类。如天气预测概率。
朴素贝叶斯（Naive Bayes, NB）适合场景：为估计一个结果的概率，从众多属性中提取的信息应该被同时考虑。
很多算法忽略了弱影响的特征（若有大量弱影响的特征，它们组合在一起的影响可能会很大），但NB算法利用了所有可以获得的证据来修正预测。
贝叶斯方法的基本概念：事件，试验，概率，联合概率，独立事件，相关事件（建立预测模型的基础），条件概率，先验概率，似然概率，边际似然概率，后验概率，频率表
条件概率公式（事件B已经发生的条件下，事件A发生的概率）：
后验概率（如商业垃圾邮件过滤器：判断viagra是垃圾邮件spam的概率）：

2）朴素贝叶斯算法

NB优点：简单快速有效；能处理噪音及缺失值数据；训练集不限大小；容易获得估计概率值。
NB缺点：依赖同样重要和独立的特征（错误假设）；应用在大量数值特征的数据集中不理想；概率估计值比预测的类更不可靠。
“朴素”的含义：基于这样一个假设：数据集的所有特征都具有相同的重要性和独立性，但在大多数实际应用中，假设不成立。
朴素贝叶斯算法具通用性和准确性，在分类学习任务中很强大。

①朴素贝叶斯分类

假设有4个单词的100封邮件的似然表来训练朴素贝叶斯算法（如下表)，收到新邮件时（包含了单词viagra和unsubscribe，但不包含money和groceries），通过计算后验概率来判断它是否为垃圾邮件。

原始的基于贝叶斯定理的后验概率：

将4个单词事件视为独立事件（类条件独立），可简化公式：

计算垃圾邮件总似然为：

计算非垃圾邮件总似然为：

是垃圾邮件的概率为：

②拉普拉斯估计

对于类中一个或多个水平，如果一个时间从没有发生过，那它出现的概率为0，从而导致后验概率值也为0（抵消或否决了所有其他的证据）。

比如，这次的新邮件中包含了前述的4个单词，则计算垃圾邮件的似然：

该邮件是垃圾邮件的概率为：

拉普拉斯估计就是给频率表中每个计数加上一个很小的数（一般设为1），保证每一类中每个特征发生的概率是非零的。

拉普拉斯估计后的垃圾邮件似然：

③数值型特征值离散化

前面的频率表要求特征必须为分类变量，如果是数值变量，需要将数值离散化（分段），如根据时间寻找分割点。如果没有明显的分割点，也可利用分位数进行分段。

但将数值特征离散化总是会导致信息量的减少，因为特征的原始粒度减少为几个数目较少的类别。分段太少会导致重要趋势被掩盖，分段太多会导致频率表中的计数值很小，因此需要平衡分段数。

2.朴素贝斯分类应用

示例：基于贝叶斯算法的手机垃圾短信过滤。

1）收集数据

数据下载sms_spam.csv：

链接: https://pan.baidu.com/s/1fAufKXCSufwd8It_DHXyWQ 提取码: vgyj

2）探索和准备数据

## Example: Filtering spam SMS messages ----

## Step 2: Exploring and preparing the data ---- 

# read the sms data into the sms data frame

sms_raw <- read.csv("sms_spam.csv", stringsAsFactors = FALSE)

# examine the structure of the sms data

str(sms_raw)

# convert spam/ham to factor.

sms_raw$type <- factor(sms_raw$type)

# examine the type variable more carefully

str(sms_raw$type)

table(sms_raw$type)

处理和分析文本数据

文本挖掘包tm创建语料库（文本集合），inspect函数查看语料库内容，tm_map函数转换tm语料库（如去数字，变小写等），stopwords函数去除填充词（如to/and/or/but等）。

清理完后标记分解单词形成的组，并创建稀疏矩阵。再进行训练集和测试集划分，并利用词云进行可视化文本数据。最后为高频词创建指示特征。

PS：运行过程中tm包的tolower参数一直报错，未解决，因此本示例最终没有用此参数。



# build a corpus using the text mining (tm) package

library(tm)

sms_corpus <- VCorpus(VectorSource(sms_raw$text))

# examine the sms corpus

print(sms_corpus)

inspect(sms_corpus[1:2])

as.character(sms_corpus[[1]])

lapply(sms_corpus[1:2], as.character)

# clean up the corpus using tm_map()

# sms_corpus_clean <- tm_map(sms_corpus, content_transformer(tolower)) #Error

sms_corpus_clean <- sms_corpus

# show the difference between sms_corpus and corpus_clean

as.character(sms_corpus[[1]])

as.character(sms_corpus_clean[[1]])

sms_corpus_clean <- tm_map(sms_corpus_clean, removeNumbers) # remove numbers

sms_corpus_clean <- tm_map(sms_corpus_clean, removeWords, stopwords()) # remove stop words

sms_corpus_clean <- tm_map(sms_corpus_clean, removePunctuation) # remove punctuation

# tip: create a custom function to replace (rather than remove) punctuation

removePunctuation("hello...world")

replacePunctuation <- function(x) { gsub("[[:punct:]]+", " ", x) }

replacePunctuation("hello...world")

# illustration of word stemming

library(SnowballC)

wordStem(c("learn", "learned", "learning", "learns"))

sms_corpus_clean <- tm_map(sms_corpus_clean, stemDocument)

sms_corpus_clean <- tm_map(sms_corpus_clean, stripWhitespace) # eliminate unneeded whitespace

# examine the final clean corpus

lapply(sms_corpus[1:3], as.character)

lapply(sms_corpus_clean[1:3], as.character)

# create a document-term sparse matrix

sms_dtm <- DocumentTermMatrix(sms_corpus_clean)

# alternative solution: create a document-term sparse matrix directly from the SMS corpus

sms_dtm2 <- DocumentTermMatrix(sms_corpus, control = list(

  # tolower = TRUE,  #注释掉也报错

  removeNumbers = TRUE,

  stopwords = TRUE,

  removePunctuation = TRUE,

  stemming = TRUE

))

# alternative solution: using custom stop words function ensures identical result

sms_dtm3 <- DocumentTermMatrix(sms_corpus, control = list(

  # tolower = TRUE, #注释掉也报错

  removeNumbers = TRUE,

  stopwords = function(x) { removeWords(x, stopwords()) },

  removePunctuation = TRUE,

  stemming = TRUE

))

# compare the result

sms_dtm

sms_dtm2

sms_dtm3

# creating training and test datasets

sms_dtm_train <- sms_dtm[1:4169, ]

sms_dtm_test  <- sms_dtm[4170:5558, ]

# also save the labels

sms_train_labels <- sms_raw[1:4169, ]$type

sms_test_labels  <- sms_raw[4170:5558, ]$type

# check that the proportion of spam is similar

prop.table(table(sms_train_labels))

prop.table(table(sms_test_labels))

# word cloud visualization

library(wordcloud)

wordcloud(sms_corpus_clean, min.freq = 50, random.order = FALSE)

# subset the training data into spam and ham groups

spam <- subset(sms_raw, type == "spam")

ham  <- subset(sms_raw, type == "ham")

wordcloud(spam$text, max.words = 40, scale = c(3, 0.5))

wordcloud(ham$text, max.words = 40, scale = c(3, 0.5))

sms_dtm_freq_train <- removeSparseTerms(sms_dtm_train, 0.999)

sms_dtm_freq_train

# indicator features for frequent words

findFreqTerms(sms_dtm_train, 5)

# save frequently-appearing terms to a character vector

sms_freq_words <- findFreqTerms(sms_dtm_train, 5)

str(sms_freq_words)

# create DTMs with only the frequent terms

sms_dtm_freq_train <- sms_dtm_train[ , sms_freq_words]

sms_dtm_freq_test <- sms_dtm_test[ , sms_freq_words]

# convert counts to a factor

convert_counts <- function(x) {

  x <- ifelse(x > 0, "Yes", "No")

}

# apply() convert_counts() to columns of train/test data

sms_train <- apply(sms_dtm_freq_train, MARGIN = 2, convert_counts)

sms_test  <- apply(sms_dtm_freq_test, MARGIN = 2, convert_counts)

得到的sms_train和sms_test的单词稀疏矩阵如下表所示：

3）训练模型

上例已经将原始短信转换为可以用一个统计模型代表的形式，因此用NB算法根据单词的存在与否来估计一条给定的短信是垃圾短信的概率。

使用e1071::naiveBays()或klaR::NaiveBayes()函数。

## Step 3: Training a model on the data ----

library(e1071)

sms_classifier <- naiveBayes(sms_train, sms_train_labels)

4）评估模型性能

基于测试集中的未知短信来检验分类器的预测值。比较预测值和真实值，仍然通过混淆矩阵来计算。

## Step 4: Evaluating model performance ----

sms_test_pred <- predict(sms_classifier, sms_test)

library(gmodels)

CrossTable(sms_test_pred, sms_test_labels,

           prop.chisq = FALSE, prop.t = FALSE, prop.r = FALSE,

           dnn = c('predicted', 'actual'))

没怎么处理效果也比较好，所以NB是文本分类的一种标准算法。同样地，假阴性问题带来的代价较大（把正常短信过滤掉了），进一步提升模型性能试试。

5）提升模型性能

上面训练时，没有设置拉普拉斯估计，此处设为1，性能有所提升。

## Step 5: Improving model performance ----

sms_classifier2 <- naiveBayes(sms_train,

                          sms_train_labels,

                          laplace = 1) #拉普拉斯估计值

sms_test_pred2 <- predict(sms_classifier2, sms_test)

CrossTable(sms_test_pred2, sms_test_labels,

           prop.chisq = FALSE, prop.t = FALSE, prop.r = FALSE,

           dnn = c('predicted', 'actual'))

码农公寓