R语言自动提取新闻摘要的简单实现

之前用R做过一些文本处理的工作，主要就是对新闻做做分类、提取关键词之类的，通过jiebaR包和自定义词典可以轻松地完成大部分工作，分类也就是整理一下各类别的特征然后跑一个分类模型就能得到比较满意的结果，唯独自动生成摘要这块一直没有找到很好的解决方法，没有找到R中现成的工具包。由于写代码能力也比较捉鸡，所以参考了java和python中的代码之后还是无法写出像样的程序出来。于是最终的解决方案就是把文章的前几句话截取出来当成摘要，效果可想而知...

随着对R和python越来越熟悉，并且最近读到了一篇详细讲解python实现textRank算法的文章（《你还在被标题党蒙骗吗？是时候试试文本摘要技术了（附源码）》），于是动手试了一下将其改成R代码，经过一番“艰苦”的搬运之后终于能在R中实现自动提取摘要的功能了。

textRank算法的原理就不过多介绍了（想了解的可以参考这里），直接说一下代码：

1. 加载包

if(!"jiebaR" %in% (.packages())) library(jiebaR)
if(!"dplyr" %in% (.packages())) library(dplyr)
keys <- worker("keywords",topn = 10)

程序中主要用到了jiebaR包和dplyr包，需加载到当前环境中，并初始化一个用于提取关键词的分词引擎keys。这里默认了10个关键词，因为处理的新闻文本文字量不大，所以10个关键词能够满足需求。对于长文本可以适当添加关键词数量。

2. 单句切割

定义一个切割句子的函数，利用punctuationVec里的标点符号来作为分割标识符。这里相比于python代码做了一些简化，因为新闻中一般不会出现~和！！！之类的标点符号，因此没有对这些标点做考虑。除此之外英文句号.也没有考虑，因为会和小数点混淆，暂时没有想到很好的区分方法，于是就暂时去掉了。。。所以只适合做中文摘要的提取。 

get_sentences <- function(text,punctuationVec = c("!","?","。","！","？",">")){
  sentences <- c()
  start_word_position <- 1
  word_position <- 1
  splitwords <- strsplit(text,split="") %>% unlist
  for(i in 1:length(splitwords)){
    word_position <- word_position + 1
    if(splitwords[i] %in% punctuationVec & !(splitwords[i+1] %in% c("”","。"))){
      sentences <- append(sentences,substr(text,start_word_position,word_position-1))
      start_word_position <- word_position
    }
  }
  return(sentences)
}

3. 关键句筛选

单句切分之后对句子的集合做一下筛选，对于长度过短的句子，或者不包含整篇文本关键词的句子予以剔除，保留重要性比较高的句子。这里还去掉了一些标题性的句子，标题一般不会包含断句的标点符号，以此作为依据识别并剔除。

filter_sentences <- function(text){
  keyw <- keywords(.,keys)
  sentences <- get_sentences(text)
  if(sum(nchar(sentences) < 15) > 0) sentences <- sentences[-which(nchar(sentences) < 15)]
  keyw_num <- vector(length = length(sentences))
  for(i in 1:length(keyw)){
    keyw_num <- keyw_num + grepl(keyw[i],sentences)
  }
  
  if(sum(keyw_num < 2) > 0) sentences <- sentences[-which(keyw_num < 2)]
  if(sum(!grepl("[。！？“”]",sentences)) > 0) sentences <- sentences[-which(!grepl("[。！？“”]",sentences))]
  return(sentences)
}

4. 获取每个句子的关键词，生成一个list

对筛选后的句子做切词，每个句子生成一串词语集合，用于做相似度计算

get_words_list <- function(sentences){
  w_list <- list()
  for(i in 1:length(sentences)){
    w_list[[i]] <- segment(sentences[i],seg)
  }
  return(w_list)
}

5. 计算句子间的相似度

相似度计算的原则是两个句子相同单词的数量除以每个句子单词数量取log的乘积，以此生成一个相似度的矩阵，并做标准化处理

get_similarity <- function(w_list){
  num <- length(w_list)
  sim_matrix <- matrix(0,num,num)
  for(i in 1:num){
    for(j in i:num){
      sim_matrix[i,j] <- length(intersect(w_list[[i]],w_list[[j]]))/(log(length(w_list[[i]]))*log(length(w_list[[i]])))
      sim_matrix[j,i] <- sim_matrix[i,j]
    }
  }
  for(i in 1:num){
    row_sum <- sum(sim_matrix[i,])
    for(j in 1:num){
      sim_matrix[i,j] <- sim_matrix[i,j]/row_sum
    }
  }
  return(sim_matrix)
}

6. 进行textRank迭代计算，得到最终的权重向量

textRank <- function(start_weight,iters,d,sim_matrix){
  count1 <- 0
  num <- nrow(sim_matrix)
  while(count1 < iters){
    start_weight <- matrix(1,1,num)*(1-d) + ((start_weight %>% as.matrix %>% t) %*% sim_matrix) * d
    start_weight <- as.vector(start_weight)
    count1 <- count1 + 1
  }
  end_weight <- start_weight
  return(end_weight)
}

7. 定义生成摘要的函数，在内部调用以上方法

新闻文本一般不会太长，测试发现基本迭代十次左右权重就收敛了，所以这里设置为20次迭代，并限制提取的句子数量为3句。d为阻尼因子，一般取0.85。

get_zh_summary <- function(text,iters = 20,d = 0.85,sentence_num = 3){
  if(!grepl("。",text)){
    summary1 <- "" 
  }else{
    sentences <- text %>% filter_sentences
    if(length(sentences)==0){
      summary1 <- ""
    }else{
      sim_matrix <- sentences %>% get_words_list %>% get_similarity
      start_rank <- c(rep(1,nrow(sim_matrix)))
      tr <- textRank(start_rank,iters,d,sim_matrix)
      summary_num <- c()
      for(i in 1:length(tr)){
        if(sum(tr > tr[i]) < sentence_num){
          summary_num <- append(summary_num,i)
        } 
      }
      summary1 <- ""
      for(i in 1:length(summary_num)){
        summary1 <- paste0(summary1,sentences[(summary_num[i])])
      }
    }
  }
  return(summary1)
}

纯R语言版本，没做太多的优化，效率比较堪忧，而且做了一些简化处理可能会影响最终的结果，这里仅仅作为一个练手加深一下对textRank算法的理解。希望jiebaR包能够早日整合好这个功能。

<
4000
/div>