R语言--关联分析（问卷调查）

在R中用最经典的Apriori关联算法对问卷调查结果进行简单的关联分析，包括对规则的筛选，输出以及可视化。

主流程

主流程包括4个部分，数据介绍，关联分析主流程代码，主流程子代码，可视化。

数据介绍

数据包含360份问卷对14个问题的答案，类似下表：

问卷编号	Q1	Q2	Q3	Q4	···
1	大三	一线城市	安全	收费情况	···
2	大三	一线城市	相对安全	安全系数	···
3	大三	一线城市	安全	使用方便	···

关联分析主流程

##读取数据，转换成transaction格式
data <- read.csv("xxx.csv", stringsAsFactors = F)
transaction <- as.transaction(data[,-1],data[,1]) 

##关联分析，设置support,confidence,对结果按照lift排序
rules <- apriori(transaction, parameter = list(support = 0.5, confidence = 0.7))
quality(rules) <- round(quality(rules), 3)
rules.sorted <- sort(rules, by="lift")

##消除冗余项,具体看自己如何定义冗余，我的定义如下：
#类型一：同时存在 1） {A,B}=>{D}   2）{A,B,C}=>{D}，则1）是冗余项
#类型二：同时存在 1） {A,B}=>{C}   2）{A,B,C}=>{D}，则1）是冗余项
supersetLhs <- is.superset(rules.sorted@lhs, rules.sorted@lhs)   
supersetAll <- is.superset(rules.sorted, rules.sorted)
superset <- supersetLhs==supersetAll&supersetLhs==T&supersetAll==T
redundant <- colSums(superset, na.rm = T) == 1
rules.pruned <- rules.sorted[redundant]
inspect(rules.pruned)#查看结果

###转换成data.frame输出规则 
RuleFrame <- inspect.frame(rules.pruned, itemSep=",") 
write.csv(RuleFrame, "rstRuleFrame.csv")

##提取想要分析的RHS项，如rhs=“相对安全”，然后对结果进行分析
rstRule <- Rhs_Selecet(rules.pruned, "相对安全")
inspect(rstRule )
      lhs                           rhs       support confidence lift 
93  {安全性,线上购物支付}          => {相对安全} 0.506   0.809      1.087
168 {使用方便,线上购物支付,支付宝} => {相对安全} 0.503   0.757      1.017
32  {一线城市}                     => {相对安全} 0.511   0.745      1.001

主流程中的子函数

上述的主流程里包含3个子函数：

• 数据处理：as.transaction；
• Rhs的提取函数：Rhs_Selecet；
• 将规则转换成数据框格式输出:inspect.frame。

##数据转换,先转换成List格式，再转换成transaction格式。
as.transaction <- function(data, f){
  dataList <- split(data, f)
  dataList <- lapply(dataList, function(x){
    rst <- unlist(x)
    names(rst) <- NULL
    rst <- unique(rst)
    rst <- rst[-which(rst=="")]
    rst
    })
  transaction <- as(dataList, "transactions") 
  transaction
}

##右提取规则
Rhs_Selecet <- function(rules.pruned, char){
  rhs <- rules.pruned@rhs@itemInfo[(rules.pruned@rhs@data@i)+1,]
  loc <- which(rhs == char)
  rules.pruned[loc]
}


##转换成data.frame格式，先提取Lhs，并连接成一个字符串
##再提取Rhs,quality,组成一个数据框
inspect.frame <- function(rules.pruned, itemSep = ","){
  ##Lhs处理
  #提取Lhs长度
  lhsNum <- diff(rules.pruned@lhs@data@p)
  #产生标签
  lhsRuleItemsLOC <- NULL
  for(i in 1:length(lhsNum)){
    lhsRuleItemsLOC <- c(lhsRuleItemsLOC, rep(i, lhsNum[i]))
  }
  #提取Rhs，组合成字符串, 链接符号默认“，”
  lhsRuleItems <- rules.pruned@lhs@itemInfo[rules.pruned@lhs@data@i+1,]
  lhsRuleItemsList <- split(lhsRuleItems, lhsRuleItemsLOC)
  lhs <- sapply(lhsRuleItemsList, function(x){
    lhs <- x[1]
    if(length(x)>1){
      for(i in 2:length(x)){
        lhs <- paste(lhs, x[i], sep=itemSep)
      }
    }
    lhs
  })

  ##lhs处理
  rhs <- rules.pruned@rhs@itemInfo[(rules.pruned@rhs@data@i)+1,]

  ##整理结果成数据框
  csq <- data.frame(lhs, rhs, rules.pruned@quality)
  csq
}

可视化

全部规则的可视化，以及预分析Rhs项的可视化

###全部规则,气泡图，大小表示support，颜色表示Lift
library(arulesViz)
plot(rules.pruned, method = "grouped")

###部分规则,项集有向图，大小表示support，颜色表示Lift
plot(rstRule, method = "graph",control = 
          list(edgeCol="black",  main="rhs=`相对安全`"))